New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

wrk_nemo.F90 in trunk/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 2764

Last change on this file since 2764 was 2749, checked in by smasson, 13 years ago
finish bugfix done in changeset:2748, see ticket #814
File size: 41.6 KB

Rev	Line
[2590]	1	MODULE wrk_nemo
	2	!!======================================================================
	3	!! * MODULE wrk_nemo *
	4	!! NEMO work space: define and allocate work-space arrays used in
	5	!! all components of NEMO
[2661]	6	!!======================================================================
[2590]	7	!! History : 4.0 ! 2011-01 (A Porter) Original code
	8	!!----------------------------------------------------------------------
[2661]	9
	10	!!----------------------------------------------------------------------
	11	!! wrk_alloc : define in memory the work space arrays
[2688]	12	!! wrk_in_use, iwrk_in_use, wrk_in_use_xz : check the availability of a workspace
	13	!! wrk_not_released, iwrk_not_released, wrk_not_released_xz : release the workspace
[2661]	14	!! print_in_use_list : print out the table holding which workspace arrays are currently marked as in use
	15	!! get_next_arg : get the next argument
	16	!! wrk_stop : act as local alternative to ctl_stop
	17	!!----------------------------------------------------------------------
[2590]	18	USE par_oce ! ocean parameters
	19
	20	IMPLICIT NONE
	21	PRIVATE
	22
[2661]	23	PUBLIC wrk_alloc ! function called in nemogcm module (nemo_init routine)
[2688]	24	PUBLIC wrk_in_use, iwrk_in_use, wrk_in_use_xz ! function called almost everywhere
	25	PUBLIC wrk_not_released, iwrk_not_released, wrk_not_released_xz ! function called almost everywhere
[2590]	26
[2598]	27	INTEGER, PARAMETER :: num_1d_wrkspaces = 27 ! No. of 1D workspace arrays ( MAX(jpijpj,jpijpk,jpj*jpk) )
[2749]	28	INTEGER, PARAMETER :: num_2d_wrkspaces = 37 ! No. of 2D workspace arrays (jpi,jpj)
[2598]	29	INTEGER, PARAMETER :: num_3d_wrkspaces = 15 ! No. of 3D workspace arrays (jpi,jpj,jpk)
[2613]	30	INTEGER, PARAMETER :: num_4d_wrkspaces = 4 ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts)
[2590]	31
[2598]	32	INTEGER, PARAMETER :: num_xz_wrkspaces = 4 ! No. of 2D, xz workspace arrays (jpi,jpk)
[2590]	33
[2598]	34	INTEGER, PARAMETER :: num_1d_lwrkspaces = 0 ! No. of 1D logical workspace arrays
	35	INTEGER, PARAMETER :: num_2d_lwrkspaces = 3 ! No. of 2D logical workspace arrays
	36	INTEGER, PARAMETER :: num_3d_lwrkspaces = 1 ! No. of 3D logical workspace arrays
	37	INTEGER, PARAMETER :: num_4d_lwrkspaces = 0 ! No. of 4D logical workspace arrays
[2590]	38
[2598]	39	INTEGER, PARAMETER :: num_1d_iwrkspaces = 0 ! No. of 1D integer workspace arrays
	40	INTEGER, PARAMETER :: num_2d_iwrkspaces = 1 ! No. of 2D integer workspace arrays
	41	INTEGER, PARAMETER :: num_3d_iwrkspaces = 0 ! No. of 3D integer workspace arrays
	42	INTEGER, PARAMETER :: num_4d_iwrkspaces = 0 ! No. of 4D integer workspace arrays
[2590]	43	! Maximum no. of workspaces of any one dimensionality that can be
[2598]	44	! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces, num_4d_wrkspaces)
[2749]	45	INTEGER :: max_num_wrkspaces = 37
[2590]	46
	47	! If adding more arrays here, remember to increment the appropriate
	48	! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc()
	49
[2661]	50	! !! 1D, REAL(wp) workspaces
[2598]	51	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_1 , wrk_1d_2 , wrk_1d_3 , wrk_1d_4 , wrk_1d_5
	52	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_6 , wrk_1d_7 , wrk_1d_8 , wrk_1d_9 , wrk_1d_10
	53	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_11, wrk_1d_12, wrk_1d_13, wrk_1d_14, wrk_1d_15
	54	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_16, wrk_1d_17, wrk_1d_18, wrk_1d_19, wrk_1d_20
	55	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_21, wrk_1d_22, wrk_1d_23, wrk_1d_24, wrk_1d_25
	56	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_26, wrk_1d_27
[2590]	57
[2661]	58	! !! 2D, x-y, REAL(wp) workspaces
[2598]	59	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_1 , wrk_2d_2 , wrk_2d_3 , wrk_2d_4 , wrk_2d_5
	60	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_6 , wrk_2d_7 , wrk_2d_8 , wrk_2d_9 , wrk_2d_10
	61	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_11, wrk_2d_12, wrk_2d_13, wrk_2d_14, wrk_2d_15
	62	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_16, wrk_2d_17, wrk_2d_18, wrk_2d_19, wrk_2d_20
	63	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_21, wrk_2d_22, wrk_2d_23, wrk_2d_24, wrk_2d_25
	64	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_26, wrk_2d_27, wrk_2d_28, wrk_2d_29, wrk_2d_30
	65	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_31, wrk_2d_32, wrk_2d_33, wrk_2d_34, wrk_2d_35
[2749]	66	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_36, wrk_2d_37
[2590]	67
[2661]	68	! !! 2D, x-z, REAL(wp) workspaces
[2598]	69	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: wrk_xz_1, wrk_xz_2, wrk_xz_3, wrk_xz_4
	70
[2661]	71	! !! 3D, x-y-z, REAL(wp) workspaces
[2598]	72	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_1 , wrk_3d_2 , wrk_3d_3 , wrk_3d_4 , wrk_3d_5
	73	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_6 , wrk_3d_7 , wrk_3d_8 , wrk_3d_9 , wrk_3d_10
	74	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_11, wrk_3d_12, wrk_3d_13, wrk_3d_14, wrk_3d_15
[2590]	75
[2661]	76	! !! 4D, x-y-z-tra, REAL(wp) workspaces
[2598]	77	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:), TARGET, PUBLIC :: wrk_4d_1, wrk_4d_2, wrk_4d_3, wrk_4d_4
[2661]	78
	79	! !! 2D integer workspace
	80	INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: iwrk_2d_1
[2590]	81
[2661]	82	LOGICAL, DIMENSION(num_1d_wrkspaces) :: in_use_1d !: Flags to track which 1D workspace arrays are in use
	83	LOGICAL, DIMENSION(num_2d_wrkspaces) :: in_use_2d !: Flags to track which 2D workspace arrays are in use
	84	LOGICAL, DIMENSION(num_3d_wrkspaces) :: in_use_3d !: Flags to track which 3D workspace arrays are in use
	85	LOGICAL, DIMENSION(num_4d_wrkspaces) :: in_use_4d !: Flags to track which 4D workspace arrays are in use
	86	LOGICAL, DIMENSION(num_xz_wrkspaces) :: in_use_xz !: Flags to track which 2D, xz workspace arrays are in use
	87	LOGICAL, DIMENSION(num_2d_lwrkspaces) :: in_use_2dll !: Flags to track which 2D, logical workspace arrays are in use
	88	LOGICAL, DIMENSION(num_3d_lwrkspaces) :: in_use_3dll !: Flags to track which 3D, logical workspace arrays are in use
	89	LOGICAL, DIMENSION(num_2d_iwrkspaces) :: in_use_2di !: Flags to track which 2D, integer workspace arrays are in use
[2590]	90
	91	! Labels for specifying workspace type in call to print_in_use_list()
[2661]	92	INTEGER, PARAMETER :: INTEGER_TYPE = 0
	93	INTEGER, PARAMETER :: LOGICAL_TYPE = 1
	94	INTEGER, PARAMETER :: REAL_TYPE = 2
[2590]	95
[2661]	96	INTEGER :: kumout ! Local copy of numout unit number for error/warning messages
[2632]	97	LOGICAL :: llwp ! Local copy of lwp - whether we are master PE or not
	98
[2676]	99	CHARACTER(LEN=*), PARAMETER :: cform_err2 = "(/,' ===>>> : E R R O R', /,' ===========',/)" !:
	100	CHARACTER(LEN=*), PARAMETER :: cform_war2 = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !:
[2632]	101
[2590]	102	!!----------------------------------------------------------------------
[2598]	103	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
[2688]	104	!! $Id:$
[2590]	105	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	106	!!----------------------------------------------------------------------
	107	CONTAINS
	108
[2632]	109	FUNCTION wrk_alloc(iunit, lwp_arg)
[2590]	110	!!----------------------------------------------------------------------
[2598]	111	!! * FUNCTION wrk_alloc *
[2590]	112	!!
	113	!! ** Purpose : Define in memory once for all the NEMO 2D, 3D and 4d
	114	!! work space arrays
	115	!!----------------------------------------------------------------------
[2661]	116	INTEGER, INTENT(in) :: iunit ! Unit no. to use for error/warning messages in this module
	117	LOGICAL, INTENT(in) :: lwp_arg ! Value of lwp
[2632]	118	!
[2661]	119	INTEGER :: wrk_alloc ! Return value
	120	INTEGER :: extent_1d ! Extent to allocate for 1D arrays
[2688]	121	INTEGER :: ierror(6) ! local integer
[2590]	122	!!----------------------------------------------------------------------
	123	!
[2632]	124	! Save the unit number to use for err/warning messages
	125	kumout = iunit
	126	! Save whether we are master PE or not (for output messages)
	127	llwp = lwp_arg
	128	!
	129	! Extent to use for 1D work arrays - find the maximum product of
	130	! jpijpj, jpijpk and jpj*jpk and use that
[2598]	131	IF ( jpi < jpj .AND. jpi < jpk ) THEN ; extent_1d = jpj*jpk
	132	ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN ; extent_1d = jpi*jpk
	133	ELSE ; extent_1d = jpi*jpj
[2688]	134	ENDIF
[2590]	135	!
	136	! Initialise the 'in use' flags for each work-space array
[2598]	137	in_use_1d (:) = .FALSE.
	138	in_use_2d (:) = .FALSE.
	139	in_use_3d (:) = .FALSE.
	140	in_use_4d (:) = .FALSE.
	141	in_use_xz (:) = .FALSE.
[2590]	142	in_use_2dll(:) = .FALSE.
	143	in_use_3dll(:) = .FALSE.
[2598]	144	in_use_2di (:) = .FALSE.
[2688]	145	!
[2590]	146	ierror(:) = 0
[2688]	147	!
[2598]	148	ALLOCATE( wrk_1d_1 (extent_1d) , wrk_1d_2 (extent_1d) , wrk_1d_3 (extent_1d) , wrk_1d_4 (extent_1d) , &
	149	& wrk_1d_5 (extent_1d) , wrk_1d_6 (extent_1d) , wrk_1d_7 (extent_1d) , wrk_1d_8 (extent_1d) , &
	150	& wrk_1d_9 (extent_1d) , wrk_1d_10(extent_1d) , &
	151	& wrk_1d_11(extent_1d) , wrk_1d_12(extent_1d) , wrk_1d_13(extent_1d) , wrk_1d_14(extent_1d) , &
	152	& wrk_1d_15(extent_1d) , wrk_1d_16(extent_1d) , wrk_1d_17(extent_1d) , wrk_1d_18(extent_1d) , &
	153	& wrk_1d_19(extent_1d) , wrk_1d_20(extent_1d) , &
	154	& wrk_1d_21(extent_1d) , wrk_1d_22(extent_1d) , wrk_1d_23(extent_1d) , wrk_1d_24(extent_1d) , &
	155	& wrk_1d_25(extent_1d) , wrk_1d_26(extent_1d) , wrk_1d_27(extent_1d) , STAT=ierror(1) )
[2661]	156	!
[2598]	157	ALLOCATE( wrk_2d_1 (jpi,jpj) , wrk_2d_2 (jpi,jpj) , wrk_2d_3 (jpi,jpj) , wrk_2d_4 (jpi,jpj) , &
	158	& wrk_2d_5 (jpi,jpj) , wrk_2d_6 (jpi,jpj) , wrk_2d_7 (jpi,jpj) , wrk_2d_8 (jpi,jpj) , &
	159	& wrk_2d_9 (jpi,jpj) , wrk_2d_10(jpi,jpj) , &
	160	& wrk_2d_11(jpi,jpj) , wrk_2d_12(jpi,jpj) , wrk_2d_13(jpi,jpj) , wrk_2d_14(jpi,jpj) , &
	161	& wrk_2d_15(jpi,jpj) , wrk_2d_16(jpi,jpj) , wrk_2d_17(jpi,jpj) , wrk_2d_18(jpi,jpj) , &
	162	& wrk_2d_19(jpi,jpj) , wrk_2d_20(jpi,jpj) , &
	163	& wrk_2d_21(jpi,jpj) , wrk_2d_22(jpi,jpj) , wrk_2d_23(jpi,jpj) , wrk_2d_24(jpi,jpj) , &
	164	& wrk_2d_25(jpi,jpj) , wrk_2d_26(jpi,jpj) , wrk_2d_27(jpi,jpj) , wrk_2d_28(jpi,jpj) , &
	165	& wrk_2d_29(jpi,jpj) , wrk_2d_30(jpi,jpj) , &
	166	& wrk_2d_31(jpi,jpj) , wrk_2d_32(jpi,jpj) , wrk_2d_33(jpi,jpj) , wrk_2d_34(jpi,jpj) , &
[2749]	167	& wrk_2d_35(jpi,jpj) , wrk_2d_36(jpi,jpj) , wrk_2d_37(jpi,jpj) , STAT=ierror(2) )
[2661]	168	!
[2598]	169	ALLOCATE( wrk_3d_1 (jpi,jpj,jpk) , wrk_3d_2 (jpi,jpj,jpk) , wrk_3d_3 (jpi,jpj,jpk) , wrk_3d_4 (jpi,jpj,jpk) , &
	170	& wrk_3d_5 (jpi,jpj,jpk) , wrk_3d_6 (jpi,jpj,jpk) , wrk_3d_7 (jpi,jpj,jpk) , wrk_3d_8 (jpi,jpj,jpk) , &
	171	& wrk_3d_9 (jpi,jpj,jpk) , wrk_3d_10(jpi,jpj,jpk) , &
	172	& wrk_3d_11(jpi,jpj,jpk) , wrk_3d_12(jpi,jpj,jpk) , wrk_3d_13(jpi,jpj,jpk) , wrk_3d_14(jpi,jpj,jpk) , &
	173	& wrk_3d_15(jpi,jpj,jpk) , STAT=ierror(3) )
[2661]	174	!
[2598]	175	ALLOCATE( wrk_4d_1(jpi,jpj,jpk,jpts) , wrk_4d_2(jpi,jpj,jpk,jpts), &
	176	& wrk_4d_3(jpi,jpj,jpk,jpts) , wrk_4d_4(jpi,jpj,jpk,jpts), STAT=ierror(4) )
[2661]	177	!
[2598]	178	ALLOCATE( wrk_xz_1(jpi,jpk) , wrk_xz_2(jpi,jpk) , wrk_xz_3(jpi,jpk) , wrk_xz_4(jpi,jpk) , STAT=ierror(5) )
[2661]	179	!
[2688]	180	ALLOCATE( iwrk_2d_1(jpi,jpj) , STAT=ierror(6) )
[2590]	181	!
[2598]	182	wrk_alloc = MAXVAL( ierror )
[2661]	183	!
[2590]	184	! Calling routine, nemo_alloc(), checks for errors and takes
	185	! appropriate action - we just print a warning message
[2632]	186	IF( wrk_alloc /= 0 ) THEN
[2676]	187	WRITE(kumout,cform_war2)
[2632]	188	WRITE(kumout,*) 'wrk_alloc: allocation of workspace arrays failed'
[2688]	189	ENDIF
[2598]	190	!
[2590]	191	END FUNCTION wrk_alloc
	192
	193
[2633]	194	FUNCTION wrk_in_use( kdim, index1, index2, index3, index4, &
	195	& index5, index6, index7, index8, index9, &
	196	& index10, index11, index12, index13, index14, &
	197	& index15, index16, index17, index18, index19, &
	198	& index20, index21, index22, index23, index24, &
	199	& index25, index26, index27)
[2590]	200	!!----------------------------------------------------------------------
[2633]	201	!! * FUNCTION wrk_in_use *
[2590]	202	!!
	203	!! ** Purpose : Request a set of KIND(wp) workspaces to use. Returns
[2634]	204	!! .TRUE. if any of those requested are already in use,
	205	!! .FALSE. otherwise.
[2590]	206	!!
[2661]	207	!! ** Method : Sets internal flags to signal that requested workspaces are in use.
	208	!! key_no_workspace_check defined ==> always return FALSE
[2590]	209	!!----------------------------------------------------------------------
[2661]	210	INTEGER , INTENT(in) :: kdim ! Dimensionality of requested workspace(s)
	211	INTEGER , INTENT(in) :: index1 ! Index of first requested workspace
	212	INTEGER, OPTIONAL, INTENT(in) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9, index10
[2598]	213	INTEGER, OPTIONAL, INTENT(in) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
	214	INTEGER, OPTIONAL, INTENT(in) :: index21, index22, index23, index24, index25, index26, index27
	215	!
[2633]	216	LOGICAL :: wrk_in_use ! Return value
[2598]	217	INTEGER :: iarg, iptr ! local integer
[2590]	218	!!----------------------------------------------------------------------
[2688]	219	!
[2634]	220	wrk_in_use = .FALSE.
[2688]	221	!
	222	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	223	! NB: check not available with AGRIF
	224	!
[2598]	225	iptr = index1
	226	iarg = 1
[2688]	227	!
	228	DO WHILE( .NOT. wrk_in_use .AND. iarg <= max_num_wrkspaces )
[2598]	229	!
	230	IF( kdim == 1 ) THEN
	231	IF( iptr > num_1d_wrkspaces ) THEN
[2633]	232	CALL wrk_stop('wrk_in_use - more 1D workspace arrays requested than defined in wrk_nemo module')
[2634]	233	wrk_in_use = .TRUE.
[2590]	234	EXIT
[2598]	235	ELSEIF( in_use_1d(iptr) ) THEN
[2634]	236	wrk_in_use = .TRUE.
[2590]	237	CALL print_in_use_list(1, REAL_TYPE, in_use_1d)
[2598]	238	ENDIF
[2590]	239	in_use_1d(iptr) = .TRUE.
[2598]	240	!
	241	ELSEIF( kdim == 2 ) THEN
	242	IF( iptr > num_2d_wrkspaces ) THEN
[2633]	243	CALL wrk_stop('wrk_in_use - more 2D workspace arrays requested than defined in wrk_nemo module')
[2634]	244	wrk_in_use = .TRUE.
[2590]	245	EXIT
[2598]	246	ELSEIF( in_use_2d(iptr) ) THEN
[2634]	247	wrk_in_use = .TRUE.
[2590]	248	CALL print_in_use_list(2, REAL_TYPE, in_use_2d)
[2598]	249	ENDIF
[2590]	250	in_use_2d(iptr) = .TRUE.
[2598]	251	!
	252	ELSEIF( kdim == 3 ) THEN
	253	IF( iptr > num_3d_wrkspaces ) THEN
[2633]	254	CALL wrk_stop( 'wrk_in_use - more 3D workspace arrays requested than defined in wrk_nemo module' )
[2634]	255	wrk_in_use = .TRUE.
[2590]	256	EXIT
[2598]	257	ELSEIF( in_use_3d(iptr) ) THEN
[2634]	258	wrk_in_use = .TRUE.
[2590]	259	CALL print_in_use_list(3, REAL_TYPE, in_use_3d)
[2598]	260	ENDIF
[2590]	261	in_use_3d(iptr) = .TRUE.
[2598]	262	!
	263	ELSEIF( kdim == 4 ) THEN
[2590]	264	IF(iptr > num_4d_wrkspaces)THEN
[2633]	265	CALL wrk_stop( 'wrk_in_use - more 4D workspace arrays requested than defined in wrk_nemo module' )
[2634]	266	wrk_in_use = .TRUE.
[2590]	267	EXIT
[2598]	268	ELSEIF( in_use_4d(iptr) ) THEN
[2634]	269	wrk_in_use = .TRUE.
[2598]	270	CALL print_in_use_list( 4, REAL_TYPE, in_use_4d )
	271	ENDIF
	272	!
[2590]	273	in_use_4d(iptr) = .TRUE.
[2598]	274	!
[2590]	275	ELSE
[2633]	276	IF(llwp) WRITE(kumout,*) 'wrk_in_use: unsupported value of kdim = ',kdim
	277	CALL wrk_stop( 'wrk_in_use: unrecognised value for number of dimensions' )
[2688]	278	ENDIF
[2590]	279
[2598]	280	CALL get_next_arg( iarg , iptr , index2, index3, index4, &
	281	& index5, index6, index7, index8, index9, &
	282	& index10, index11, index12, index13, index14, &
	283	& index15, index16, index17, index18, index19, &
	284	& index20, index21, index22, index23, index24, &
	285	& index25, index26, index27)
[2590]	286
[2598]	287	IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done
[2590]	288	EXIT
[2598]	289	ELSEIF( iarg == -99 ) THEN
[2633]	290	CALL wrk_stop( 'wrk_in_use : caught unexpected argument count - BUG' )
[2590]	291	EXIT
[2688]	292	ENDIF
[2598]	293	!
[2590]	294	END DO ! end of DO WHILE()
[2661]	295	#endif
[2598]	296	!
[2688]	297	END FUNCTION wrk_in_use
[2590]	298
	299
[2633]	300	FUNCTION iwrk_in_use( kdim, index1, index2, index3, index4, &
	301	& index5, index6, index7 )
[2590]	302	!!----------------------------------------------------------------------
[2633]	303	!! * FUNCTION iwrk_in_use *
[2590]	304	!!
	305	!! ** Purpose : Request a set of INTEGER workspaces to use. Returns
[2634]	306	!! .TRUE. if any of those requested are already in use,
	307	!! .FALSE. otherwise.
[2590]	308	!!
[2634]	309	!! ** Method : Sets internal flags to signal that requested workspaces
	310	!! are in use.
[2590]	311	!!----------------------------------------------------------------------
[2661]	312	INTEGER , INTENT(in) :: kdim ! Dimensionality of requested workspace(s)
	313	INTEGER , INTENT(in) :: index1 ! Index of first requested workspace
[2598]	314	INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7
	315	!
[2661]	316	LOGICAL :: iwrk_in_use ! Return value
	317	INTEGER :: iarg, iptr
[2590]	318	!!----------------------------------------------------------------------
[2661]	319	!
[2634]	320	iwrk_in_use = .FALSE.
[2661]	321	!
[2688]	322	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	323	! NB: check not available with AGRIF
[2661]	324	!
[2598]	325	iptr = index1
	326	iarg = 1
[2688]	327	!
	328	DO WHILE( .NOT.iwrk_in_use .AND. iarg <= max_num_wrkspaces )
[2598]	329	!
	330	IF( kdim == 2 ) THEN
	331	IF( iptr > num_2d_wrkspaces ) THEN
[2633]	332	CALL wrk_stop( 'wrk_in_use - more 2D workspace arrays requested than defined in wrk_nemo module' )
[2634]	333	iwrk_in_use = .TRUE.
[2598]	334	ELSEIF( in_use_2di(iptr) ) THEN
[2634]	335	iwrk_in_use = .TRUE.
[2598]	336	CALL print_in_use_list( 2, INTEGER_TYPE, in_use_2di )
[2688]	337	ENDIF
[2590]	338	in_use_2di(iptr) = .TRUE.
[2598]	339	!
[2590]	340	ELSE
[2633]	341	IF(llwp) WRITE(kumout,*) 'iwrk_in_use: unsupported value of kdim = ',kdim
	342	CALL wrk_stop('iwrk_in_use: unsupported value for number of dimensions')
[2688]	343	ENDIF
	344	!
	345	SELECT CASE (iarg) ! Move on to next optional argument
[2590]	346	CASE ( 1 )
[2598]	347	IF( .NOT. PRESENT(index2) ) THEN ; EXIT
	348	ELSE ; iarg = 2 ; iptr = index2
[2688]	349	ENDIF
[2590]	350	CASE ( 2 )
[2598]	351	IF( .NOT. PRESENT(index3) ) THEN ; EXIT
	352	ELSE ; iarg = 3 ; iptr = index3
[2688]	353	ENDIF
[2590]	354	CASE ( 3 )
[2598]	355	IF( .NOT. PRESENT(index4) ) THEN ; EXIT
	356	ELSE ; iarg = 4 ; iptr = index4
[2688]	357	ENDIF
[2590]	358	CASE ( 4 )
[2598]	359	IF( .NOT. PRESENT(index5) ) THEN ; EXIT
	360	ELSE ; iarg = 5 ; iptr = index5
[2688]	361	ENDIF
[2590]	362	CASE ( 5 )
[2598]	363	IF( .NOT. PRESENT(index6) ) THEN ; EXIT
	364	ELSE ; iarg = 6 ; iptr = index6
[2688]	365	ENDIF
[2590]	366	CASE ( 6 )
[2598]	367	IF( .NOT. PRESENT(index7) ) THEN ; EXIT
	368	ELSE ; iarg = 7 ; iptr = index7
[2688]	369	ENDIF
[2590]	370	CASE ( 7 )
	371	EXIT
	372	CASE DEFAULT
[2633]	373	CALL wrk_stop( 'iwrk_in_use : caught unexpected argument count - BUG' )
[2590]	374	EXIT
	375	END SELECT
[2598]	376	!
[2590]	377	END DO ! end of DO WHILE()
[2661]	378	#endif
[2598]	379	!
[2688]	380	END FUNCTION iwrk_in_use
[2590]	381
	382
[2633]	383	FUNCTION wrk_in_use_xz( index1, index2, index3, index4, &
	384	& index5, index6, index7, index8, index9 )
[2590]	385	!!----------------------------------------------------------------------
[2633]	386	!! * FUNCTION wrk_in_use_xz *
[2590]	387	!!
	388	!! ** Purpose : Request a set of 2D, xz (jpi,jpk) workspaces to use.
[2634]	389	!! Returns .TRUE. if any of those requested are already in
	390	!! use, .FALSE. otherwise.
[2590]	391	!!
[2634]	392	!! ** Method : Sets internal flags to signal that requested workspaces
	393	!! are in use.
[2590]	394	!!----------------------------------------------------------------------
[2661]	395	INTEGER , INTENT(in) :: index1 ! Index of first requested workspace
	396	INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5
	397	INTEGER, OPTIONAL, INTENT(in) :: index6, index7, index8, index9
	398	!
[2633]	399	LOGICAL :: wrk_in_use_xz ! Return value
	400	INTEGER :: iarg, iptr ! local integer
[2590]	401	!!----------------------------------------------------------------------
[2661]	402	!
[2634]	403	wrk_in_use_xz = .FALSE.
[2661]	404	!
[2688]	405	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	406	! NB: check not available with AGRIF
[2661]	407	!
[2688]	408	iptr = index1
	409	iarg = 1
	410	!
	411	DO WHILE( .NOT. wrk_in_use_xz .AND. iarg <= max_num_wrkspaces )
[2598]	412	!
[2688]	413	IF( iptr > num_xz_wrkspaces ) THEN
[2633]	414	CALL wrk_stop('wrk_in_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module')
[2634]	415	wrk_in_use_xz = .TRUE.
[2598]	416	EXIT
[2661]	417	ELSE IF( in_use_xz(iptr) ) THEN
[2634]	418	wrk_in_use_xz = .TRUE.
[2598]	419	CALL print_in_use_list(2, REAL_TYPE, in_use_xz) !ARPDBG - bug
[2688]	420	ENDIF
[2598]	421	!
	422	in_use_xz(iptr) = .TRUE.
	423	!
[2688]	424	CALL get_next_arg( iarg , iptr , index2, index3, index4, &
	425	& index5, index6, index7, index8, index9 )
[2598]	426	!
	427	IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done
[2590]	428	EXIT
[2598]	429	ELSEIF( iarg == -99 ) THEN
[2633]	430	CALL wrk_stop( 'wrk_in_use_xz : caught unexpected argument count - BUG' ) ; EXIT
[2688]	431	ENDIF
[2598]	432	!
[2635]	433	END DO ! while( (.NOT. wrk_in_use_xz) .AND. iarg <= max_num_wrkspaces)
[2661]	434	#endif
[2598]	435	!
[2633]	436	END FUNCTION wrk_in_use_xz
[2590]	437
	438
[2633]	439	FUNCTION wrk_not_released( kdim, index1, index2, index3, index4, &
	440	& index5, index6, index7, index8, index9, &
	441	& index10, index11, index12, index13, index14, &
	442	& index15, index16, index17, index18, index19, &
	443	& index20, index21, index22, index23, index24, &
	444	& index25, index26, index27)
[2598]	445	!!----------------------------------------------------------------------
[2633]	446	!! * FUNCTION wrk_not_released *
[2598]	447	!!
[2634]	448	!! ** Purpose : Flag that the specified workspace arrays are no-longer
	449	!! in use.
[2598]	450	!!----------------------------------------------------------------------
[2661]	451	INTEGER , INTENT(in) :: kdim ! Dimensionality of workspace(s)
	452	INTEGER , INTENT(in) :: index1 ! Index of 1st workspace to release
[2598]	453	INTEGER, OPTIONAL, INTENT(in) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10
	454	INTEGER, OPTIONAL, INTENT(in) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
	455	INTEGER, OPTIONAL, INTENT(in) :: index21, index22, index23, index24, index25, index26, index27
	456	!
[2661]	457	LOGICAL :: wrk_not_released ! Return value
	458	INTEGER :: iarg, iptr
[2598]	459	!!----------------------------------------------------------------------
[2661]	460	!
[2634]	461	wrk_not_released = .FALSE.
[2661]	462	!
[2688]	463	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	464	! NB: check not available with AGRIF
[2661]	465	!
[2598]	466	iptr = index1
	467	iarg = 1
[2688]	468	!
[2598]	469	DO WHILE( iarg <= max_num_wrkspaces )
	470	!
	471	IF( kdim == 1 ) THEN
	472	IF( iptr > num_1d_wrkspaces ) THEN
[2633]	473	CALL wrk_stop( 'wrk_not_released : attempt to release a non-existent 1D workspace array' )
[2634]	474	wrk_not_released = .TRUE.
[2598]	475	ELSE
	476	in_use_1d(iptr) = .FALSE.
	477	ENDIF
	478	!
[2688]	479	ELSE IF(kdim == 2) THEN
[2598]	480	IF( iptr > num_2d_wrkspaces ) THEN
[2633]	481	CALL wrk_stop( 'wrk_not_released : attempt to release a non-existent 2D workspace array' )
[2634]	482	wrk_not_released = .TRUE.
[2598]	483	ENDIF
	484	in_use_2d(iptr) = .FALSE.
	485	!
	486	ELSEIF( kdim == 3 ) THEN
	487	IF( iptr > num_3d_wrkspaces ) THEN
[2633]	488	CALL wrk_stop('wrk_not_released : attempt to release a non-existent 3D workspace array')
[2634]	489	wrk_not_released = .TRUE.
[2688]	490	ENDIF
[2598]	491	in_use_3d(iptr) = .FALSE.
	492	!
	493	ELSEIF( kdim == 4 ) THEN
[2688]	494	IF( iptr > num_4d_wrkspaces ) THEN
[2634]	495	CALL wrk_stop('wrk_not_released : attempt to release a non-existent 4D workspace array')
	496	wrk_not_released = .TRUE.
[2688]	497	ENDIF
[2598]	498	in_use_4d(iptr) = .FALSE.
	499	!
	500	ELSE
[2633]	501	IF(llwp) WRITE(kumout,*) 'wrk_not_released: unsupported value of kdim = ',kdim
	502	CALL wrk_stop('wrk_not_released: unrecognised value for number of dimensions')
[2598]	503	ENDIF
[2688]	504	!
[2598]	505	! Move on to next optional argument
	506	CALL get_next_arg( iarg , iptr , index2, index3, index4, &
	507	& index5, index6, index7, index8, index9, &
	508	& index10, index11, index12, index13, &
	509	& index14, index15, index16, index17, &
	510	& index18, index19, index20, index21, &
	511	& index22, index23, index24, index25, &
	512	& index26, index27 )
[2590]	513
[2598]	514	IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done
	515	EXIT
	516	ELSEIF( iarg == -99 ) THEN
[2633]	517	CALL wrk_stop('wrk_not_released - caught unexpected argument count - BUG') ; EXIT
[2688]	518	ENDIF
[2598]	519	!
[2590]	520	END DO ! end of DO WHILE()
[2661]	521	#endif
[2598]	522	!
[2633]	523	END FUNCTION wrk_not_released
[2590]	524
	525
[2633]	526	FUNCTION iwrk_not_released( kdim, index1, index2, index3, index4, &
	527	& index5, index6, index7 )
[2598]	528	!!----------------------------------------------------------------------
[2633]	529	!! * FUNCTION iwrk_not_released *
[2598]	530	!!
	531	!! ** Purpose : Flag that the specified INTEGER workspace arrays are
	532	!! no-longer in use.
	533	!!----------------------------------------------------------------------
[2661]	534	INTEGER , INTENT(in) :: kdim ! Dimensionality of workspace(s)
	535	INTEGER , INTENT(in) :: index1 ! Index of 1st workspace to release
	536	INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7
[2598]	537	!
[2633]	538	LOGICAL :: iwrk_not_released ! Return value
	539	INTEGER :: iarg, iptr ! local integer
[2598]	540	!!----------------------------------------------------------------------
	541	!
[2634]	542	iwrk_not_released = .FALSE.
[2661]	543	!
[2688]	544	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	545	! NB: check not available with AGRIF
[2661]	546	!
[2688]	547	iptr = index1
	548	iarg = 1
[2598]	549	!
	550	DO WHILE(iarg <= max_num_wrkspaces)
	551	!
	552	IF( kdim == 2 ) THEN
	553	IF( iptr > num_2d_iwrkspaces ) THEN
[2633]	554	CALL wrk_stop('iwrk_not_released : attempt to release a non-existant 2D workspace array')
[2634]	555	iwrk_not_released = .TRUE.
[2598]	556	ENDIF
	557	in_use_2di(iptr) = .FALSE.
	558	ELSE
[2633]	559	IF(llwp) WRITE(kumout,*) 'iwrk_not_released: unsupported value of kdim = ',kdim
	560	CALL wrk_stop('iwrk_not_released: unsupported value for number of dimensions')
[2598]	561	ENDIF
	562	!
	563	! Move on to next optional argument
	564	SELECT CASE (iarg)
	565	CASE ( 1 )
	566	IF( .NOT. PRESENT(index2) ) THEN ; EXIT
	567	ELSE ; iarg = 2 ; iptr = index2
[2688]	568	ENDIF
[2598]	569	CASE ( 2 )
	570	IF( .NOT. PRESENT(index3) ) THEN ; EXIT
	571	ELSE ; iarg = 3 ; iptr = index3
[2688]	572	ENDIF
[2598]	573	CASE ( 3 )
	574	IF( .NOT. PRESENT(index4) ) THEN ; EXIT
	575	ELSE ; iarg = 4 ; iptr = index4
[2688]	576	ENDIF
[2598]	577	CASE ( 4 )
	578	IF( .NOT. PRESENT(index5) ) THEN ; EXIT
	579	ELSE ; iarg = 5 ; iptr = index5
[2688]	580	ENDIF
[2598]	581	CASE ( 5 )
	582	IF( .NOT. PRESENT(index6) ) THEN ; EXIT
	583	ELSE ; iarg = 6 ; iptr = index6
[2688]	584	ENDIF
[2598]	585	CASE ( 6 )
	586	IF( .NOT. PRESENT(index7) ) THEN ; EXIT
	587	ELSE ; iarg = 7 ; iptr = index7
[2688]	588	ENDIF
[2598]	589	CASE ( 7 )
	590	EXIT
	591	CASE DEFAULT
[2633]	592	CALL wrk_stop( 'iwrk_not_released : caught unexpected argument count - BUG' )
[2598]	593	EXIT
	594	END SELECT
	595	!
	596	END DO ! end of DO WHILE()
[2661]	597	#endif
[2598]	598	!
[2633]	599	END FUNCTION iwrk_not_released
[2590]	600
	601
[2633]	602	FUNCTION wrk_not_released_xz( index1, index2, index3, index4, index5, &
	603	& index6, index7, index8, index9 )
[2598]	604	!!----------------------------------------------------------------------
[2633]	605	!! * FUNCTION wrk_not_released_xz *
[2598]	606	!!
	607	!!----------------------------------------------------------------------
[2661]	608	INTEGER , INTENT(in) :: index1 ! Index of 1st workspace to release
	609	INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9
[2598]	610	!
[2633]	611	LOGICAL :: wrk_not_released_xz ! Return value
	612	INTEGER :: iarg, iptr ! local integer
[2598]	613	!!----------------------------------------------------------------------
	614	!
[2634]	615	wrk_not_released_xz = .FALSE.
[2661]	616	!
[2688]	617	#if ! defined key_no_workspace_check \|\| ! defined key_agrif
	618	! NB: check not available with AGRIF
[2661]	619	!
[2598]	620	iptr = index1
	621	iarg = 1
	622	!
	623	DO WHILE( iarg <= max_num_wrkspaces )
	624	!
	625	IF( iptr > num_xz_wrkspaces ) THEN
[2633]	626	CALL wrk_stop('wrk_not_released_xz : attempt to release a non-existant 2D xz workspace array')
[2634]	627	wrk_not_released_xz = .TRUE.
[2598]	628	EXIT
	629	ENDIF
	630	in_use_xz(iptr) = .FALSE.
	631	!
	632	! Move on to next optional argument
	633	CALL get_next_arg( iarg, iptr, index2, index3, index4, &
	634	& index5, index6, index7, index8, index9)
	635	!
	636	IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done
	637	EXIT
	638	ELSEIF( iarg == -99 ) THEN
[2633]	639	CALL wrk_stop('wrk_not_released_xz : caught unexpected argument count - BUG')
[2598]	640	EXIT
[2688]	641	ENDIF
[2598]	642	!
	643	END DO ! while (iarg <= max_num_wrkspaces)
[2661]	644	#endif
[2598]	645	!
[2633]	646	END FUNCTION wrk_not_released_xz
[2590]	647
	648
[2598]	649	SUBROUTINE print_in_use_list( kdim, itype, in_use_list )
	650	!!----------------------------------------------------------------------
	651	!! * ROUTINE print_in_use_list *
	652	!!
[2661]	653	!! ** Purpose: to print out the table holding which workspace arrays
[2598]	654	!! are currently marked as in use.
	655	!!----------------------------------------------------------------------
	656	INTEGER, INTENT(in) :: kdim
	657	INTEGER, INTENT(in) :: itype
	658	LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list
	659	!
	660	INTEGER :: ji, icount
	661	CHARACTER(LEN=7) :: type_string
	662	!!----------------------------------------------------------------------
[2688]	663	!
[2632]	664	IF(.NOT. llwp) RETURN
[2688]	665	!
[2598]	666	SELECT CASE ( kdim )
	667	!
	668	CASE (1)
	669	SELECT CASE (itype)
	670	CASE (INTEGER_TYPE) ; icount = num_1d_iwrkspaces
	671	CASE (LOGICAL_TYPE) ; icount = num_1d_lwrkspaces
	672	CASE (REAL_TYPE ) ; icount = num_1d_wrkspaces
	673	END SELECT
	674	!
	675	CASE (2)
	676	SELECT CASE (itype)
	677	CASE (INTEGER_TYPE) ; icount = num_2d_iwrkspaces
	678	CASE (LOGICAL_TYPE) ; icount = num_2d_lwrkspaces
	679	CASE (REAL_TYPE ) ; icount = num_2d_wrkspaces
	680	END SELECT
	681	!
	682	CASE (3)
	683	SELECT CASE (itype)
	684	CASE (INTEGER_TYPE) ; icount = num_3d_iwrkspaces
	685	CASE (LOGICAL_TYPE) ; icount = num_3d_lwrkspaces
	686	CASE (REAL_TYPE ) ; icount = num_3d_wrkspaces
	687	END SELECT
	688	!
	689	CASE (4)
	690	SELECT CASE (itype)
	691	CASE (INTEGER_TYPE) ; icount = num_4d_iwrkspaces
	692	CASE (LOGICAL_TYPE) ; icount = num_4d_lwrkspaces
	693	CASE (REAL_TYPE ) ; icount = num_4d_wrkspaces
	694	END SELECT
	695	!
	696	CASE DEFAULT ; RETURN
	697	!
	698	END SELECT
[2688]	699	!
[2598]	700	! Set character string with type of workspace
	701	SELECT CASE (itype)
	702	CASE (INTEGER_TYPE) ; type_string = "INTEGER"
	703	CASE (LOGICAL_TYPE) ; type_string = "LOGICAL"
	704	CASE (REAL_TYPE ) ; type_string = "REAL"
	705	END SELECT
[2688]	706	!
[2632]	707	WRITE(kumout,*)
	708	WRITE(kumout,"('------------------------------------------')")
	709	WRITE(kumout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string)
	710	WRITE(kumout,"('Workspace In use')")
[2598]	711	DO ji = 1, icount, 1
[2632]	712	WRITE(kumout,"(4x,I2,8x,L1)") ji, in_use_list(ji)
[2598]	713	END DO
[2632]	714	WRITE(kumout,"('------------------------------------------')")
	715	WRITE(kumout,*)
[2598]	716	!
	717	END SUBROUTINE print_in_use_list
[2590]	718
	719
[2598]	720	SUBROUTINE get_next_arg( iargidx, iargval, index2, index3, index4, &
	721	& index5 , index6, index7, index8, index9, &
	722	& index10, index11, index12, index13, index14, &
	723	& index15, index16, index17, index18, index19, &
	724	& index20, index21, index22, index23, index24, &
	725	& index25, index26, index27 )
	726	!!----------------------------------------------------------------------
[2661]	727	INTEGER , INTENT(inout) :: iargidx ! Index of current arg
	728	INTEGER , INTENT(inout) :: iargval ! Value of current arg
	729	INTEGER, OPTIONAL, INTENT(in ) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10
	730	INTEGER, OPTIONAL, INTENT(in ) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
	731	INTEGER, OPTIONAL, INTENT(in ) :: index21, index22, index23, index24, index25, index26, index27
[2598]	732	!!----------------------------------------------------------------------
[2688]	733	!
[2598]	734	SELECT CASE (iargidx) ! Move on to next optional argument
	735	CASE ( 1 )
	736	IF( .NOT. PRESENT(index2 ) ) THEN ; iargidx = -1
	737	ELSE ; iargidx = 2 ; iargval = index2
	738	ENDIF
	739	CASE ( 2 )
	740	IF( .NOT. PRESENT(index3 ) ) THEN ; iargidx = -1
	741	ELSE ; iargidx = 3 ; iargval = index3
	742	ENDIF
	743	CASE ( 3 )
	744	IF( .NOT. PRESENT(index4 ) ) THEN ; iargidx = -1
	745	ELSE ; iargidx = 4 ; iargval = index4
	746	ENDIF
	747	CASE ( 4 )
	748	IF( .NOT. PRESENT(index5 ) ) THEN ; iargidx = -1
	749	ELSE ; iargidx = 5 ; iargval = index5
	750	ENDIF
	751	CASE ( 5 )
	752	IF( .NOT. PRESENT(index6 ) ) THEN ; iargidx = -1
	753	ELSE ; iargidx = 6 ; iargval = index6
	754	ENDIF
	755	CASE ( 6 )
	756	IF( .NOT. PRESENT(index7 ) ) THEN ; iargidx = -1
	757	ELSE ; iargidx = 7 ; iargval = index7
	758	ENDIF
	759	CASE ( 7 )
	760	IF( .NOT. PRESENT(index8 ) ) THEN ; iargidx = -1
	761	ELSE ; iargidx = 8 ; iargval = index8
	762	ENDIF
	763	CASE ( 8 )
[2694]	764	IF( .NOT. PRESENT(index9 ) ) THEN ; iargidx = -1
[2598]	765	ELSE ; iargidx = 9 ; iargval = index9
	766	ENDIF
	767	CASE ( 9 )
	768	IF( .NOT. PRESENT(index10) ) THEN ; iargidx = -1
	769	ELSE ; iargidx = 10 ; iargval = index10
	770	ENDIF
	771	CASE ( 10 )
	772	IF( .NOT. PRESENT(index11) ) THEN ; iargidx = -1
	773	ELSE ; iargidx = 11 ; iargval = index11
	774	ENDIF
	775	CASE ( 11 )
	776	IF( .NOT. PRESENT(index12) ) THEN ; iargidx = -1
	777	ELSE ; iargidx = 12 ; iargval = index12
	778	ENDIF
	779	CASE ( 12 )
	780	IF( .NOT. PRESENT(index13) ) THEN ; iargidx = -1
	781	ELSE ; iargidx = 13 ; iargval = index13
	782	ENDIF
	783	CASE ( 13 )
	784	IF( .NOT. PRESENT(index14) ) THEN ; iargidx = -1
	785	ELSE ; iargidx = 14 ; iargval = index14
	786	ENDIF
	787	CASE ( 14 )
	788	IF( .NOT. PRESENT(index15) ) THEN ; iargidx = -1
	789	ELSE ; iargidx = 15 ; iargval = index15
	790	ENDIF
	791	CASE ( 15 )
	792	IF( .NOT. PRESENT(index16) ) THEN ; iargidx = -1
	793	ELSE ; iargidx = 16 ; iargval = index16
	794	ENDIF
	795	CASE ( 16 )
	796	IF( .NOT. PRESENT(index17) ) THEN ; iargidx = -1
	797	ELSE ; iargidx = 17 ; iargval = index17
[2688]	798	ENDIF
[2598]	799	CASE ( 17 )
	800	IF( .NOT. PRESENT(index18) ) THEN ; iargidx = -1
	801	ELSE ; iargidx = 18 ; iargval = index18
	802	ENDIF
	803	CASE ( 18 )
	804	IF( .NOT. PRESENT(index19) ) THEN ; iargidx = -1
	805	ELSE ; iargidx = 19 ; iargval = index19
	806	ENDIF
	807	CASE ( 19 )
	808	IF( .NOT. PRESENT(index20) ) THEN ; iargidx = -1
	809	ELSE ; iargidx = 20 ; iargval = index20
	810	ENDIF
	811	CASE ( 20 )
	812	IF( .NOT. PRESENT(index21) ) THEN ; iargidx = -1
	813	ELSE ; iargidx = 21 ; iargval = index21
	814	ENDIF
	815	CASE ( 21 )
	816	IF( .NOT. PRESENT(index22) ) THEN ; iargidx = -1
	817	ELSE ; iargidx = 22 ; iargval = index22
	818	ENDIF
	819	CASE ( 22 )
	820	IF( .NOT. PRESENT(index23) ) THEN ; iargidx = -1
	821	ELSE ; iargidx = 23 ; iargval = index23
	822	ENDIF
	823	CASE ( 23 )
	824	IF( .NOT. PRESENT(index24) ) THEN ; iargidx = -1
	825	ELSE ; iargidx = 24 ; iargval = index24
	826	ENDIF
	827	CASE ( 24 )
	828	IF( .NOT. PRESENT(index25) ) THEN ; iargidx = -1
	829	ELSE ; iargidx = 25 ; iargval = index25
	830	ENDIF
	831	CASE ( 25 )
	832	IF( .NOT. PRESENT(index26) ) THEN ; iargidx = -1
	833	ELSE ; iargidx = 26 ; iargval = index26
	834	ENDIF
	835	CASE ( 26 )
	836	IF( .NOT. PRESENT(index27) ) THEN ; iargidx = -1
	837	ELSE ; iargidx = 27 ; iargval = index27
	838	ENDIF
	839	CASE ( 27 )
	840	iargidx = -1
	841	CASE DEFAULT
	842	! BUG - iargidx shouldn't take any other values!
	843	! Flag error for calling routine
	844	iargidx = -99
	845	END SELECT
	846	!
	847	END SUBROUTINE get_next_arg
[2590]	848
[2632]	849
	850	SUBROUTINE wrk_stop(cmsg)
	851	!!----------------------------------------------------------------------
	852	!! * ROUTINE wrk_stop *
[2661]	853	!! ** Purpose : to act as local alternative to ctl_stop.
	854	!! Avoids dependency on in_out_manager module.
[2632]	855	!!----------------------------------------------------------------------
	856	CHARACTER(LEN=*), INTENT(in) :: cmsg
	857	!!----------------------------------------------------------------------
[2688]	858	!
[2676]	859	WRITE(kumout, cform_err2)
[2632]	860	WRITE(kumout,*) TRIM(cmsg)
	861	! ARPDBG - would like to call mppstop here to force a stop but that
	862	! introduces a dependency on lib_mpp. Could call mpi_abort() directly
	863	! but that's fairly brutal. Better to rely on calling routine to
	864	! deal with the error passed back from the wrk_X routine?
	865	!CALL mppstop
[2688]	866	!
[2632]	867	END SUBROUTINE wrk_stop
	868
[2598]	869	!!=====================================================================
[2590]	870	END MODULE wrk_nemo

Note: See TracBrowser for help on using the repository browser.

Download in other formats: