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 branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 4401

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

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

Download in other formats: