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_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 2790

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

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

Download in other formats: