Changeset 2598 for branches/dev_r2586_dynamic_mem/NEMOGCM
- Timestamp:
- 2011-02-20T15:56:41+01:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90
r2590 r2598 17 17 PUBLIC wrk_release, llwrk_release, iwrk_release, wrk_release_xz 18 18 19 INTEGER, PARAMETER :: num_1d_wrkspaces = 27 ! No. of 1D workspace arrays ( MAX(jpi*jpj,jpi*jpk,jpj*jpk) )20 INTEGER, PARAMETER :: num_2d_wrkspaces = 35 ! No. of 2D workspace arrays (jpi,jpj)21 INTEGER, PARAMETER :: num_3d_wrkspaces = 15 ! No. of 3D workspace arrays (jpi,jpj,jpk)22 INTEGER, PARAMETER :: num_4d_wrkspaces = 4 ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts)23 24 INTEGER, PARAMETER :: num_xz_wrkspaces = 4 ! No. of 2D, xz workspace arrays (jpi,jpk)25 26 INTEGER, PARAMETER :: num_1d_lwrkspaces = 0 ! No. of 1D logical workspace arrays27 INTEGER, PARAMETER :: num_2d_lwrkspaces = 3 ! No. of 2D logical workspace arrays28 INTEGER, PARAMETER :: num_3d_lwrkspaces = 1 ! No. of 3D logical workspace arrays29 INTEGER, PARAMETER :: num_4d_lwrkspaces = 0 ! No. of 4D logical workspace arrays30 31 INTEGER, PARAMETER :: num_1d_iwrkspaces = 0 ! No. of 1D integer workspace arrays32 INTEGER, PARAMETER :: num_2d_iwrkspaces = 1 ! No. of 2D integer workspace arrays33 INTEGER, PARAMETER :: num_3d_iwrkspaces = 0 ! No. of 3D integer workspace arrays34 INTEGER, PARAMETER :: num_4d_iwrkspaces = 0 ! No. of 4D integer workspace arrays19 INTEGER, PARAMETER :: num_1d_wrkspaces = 27 ! No. of 1D workspace arrays ( MAX(jpi*jpj,jpi*jpk,jpj*jpk) ) 20 INTEGER, PARAMETER :: num_2d_wrkspaces = 35 ! No. of 2D workspace arrays (jpi,jpj) 21 INTEGER, PARAMETER :: num_3d_wrkspaces = 15 ! No. of 3D workspace arrays (jpi,jpj,jpk) 22 INTEGER, PARAMETER :: num_4d_wrkspaces = 4 ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts) 23 24 INTEGER, PARAMETER :: num_xz_wrkspaces = 4 ! No. of 2D, xz workspace arrays (jpi,jpk) 25 26 INTEGER, PARAMETER :: num_1d_lwrkspaces = 0 ! No. of 1D logical workspace arrays 27 INTEGER, PARAMETER :: num_2d_lwrkspaces = 3 ! No. of 2D logical workspace arrays 28 INTEGER, PARAMETER :: num_3d_lwrkspaces = 1 ! No. of 3D logical workspace arrays 29 INTEGER, PARAMETER :: num_4d_lwrkspaces = 0 ! No. of 4D logical workspace arrays 30 31 INTEGER, PARAMETER :: num_1d_iwrkspaces = 0 ! No. of 1D integer workspace arrays 32 INTEGER, PARAMETER :: num_2d_iwrkspaces = 1 ! No. of 2D integer workspace arrays 33 INTEGER, PARAMETER :: num_3d_iwrkspaces = 0 ! No. of 3D integer workspace arrays 34 INTEGER, PARAMETER :: num_4d_iwrkspaces = 0 ! No. of 4D integer workspace arrays 35 35 ! Maximum no. of workspaces of any one dimensionality that can be 36 ! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces, 37 ! num_4d_wrkspaces) 36 ! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces, num_4d_wrkspaces) 38 37 INTEGER, PARAMETER :: max_num_wrkspaces = 35 39 38 … … 41 40 ! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc() 42 41 43 ! 1D, REAL(wp) workspaces 44 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_1, wrk_1d_2 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_3, wrk_1d_4 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_5, wrk_1d_6 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_7, wrk_1d_8 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_9, wrk_1d_10 49 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_11, wrk_1d_12 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_13, wrk_1d_14 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_15, wrk_1d_16 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_17, wrk_1d_18 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_19, wrk_1d_20 54 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_21, wrk_1d_22 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_23, wrk_1d_24 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_25, wrk_1d_26 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_27 58 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_1 !: 2D real workspace 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_2 !: 2D real workspace 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_3 !: 2D real workspace 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_4 !: 2D real workspace 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_5 !: 2D real workspace 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_6 !: 2D real workspace 65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_7 !: 2D real workspace 66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_8 !: 2D real workspace 67 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_9 !: 2D real workspace 68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_10 !: 2D real workspace 69 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_11 !: 2D real workspace 70 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_12 !: 2D real workspace 71 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_13 !: 2D real workspace 72 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_14 !: 2D real workspace 73 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_15 !: 2D real workspace 74 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_16 !: 2D real workspace 75 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_17 !: 2D real workspace 76 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_18 !: 2D real workspace 77 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_19 !: 2D real workspace 78 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_20 !: 2D real workspace 79 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_21 !: 2D real workspace 80 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_22 !: 2D real workspace 81 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_23 !: 2D real workspace 82 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_24 !: 2D real workspace 83 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_25 !: 2D real workspace 84 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_26 !: 2D real workspace 85 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_27 !: 2D real workspace 86 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_28 !: 2D real workspace 87 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_29 !: 2D real workspace 88 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_30 !: 2D real workspace 89 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_31 !: 2D real workspace 90 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_32 !: 2D real workspace 91 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_33 !: 2D real workspace 92 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_34 !: 2D real workspace 93 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_35 !: 2D real workspace 94 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_1 !: 3D real workspace 96 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_2 !: 3D real workspace 97 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_3 !: 3D real workspace 98 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_4 !: 3D real workspace 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_5 !: 3D real workspace 100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_6 !: 3D real workspace 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_7 !: 3D real workspace 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_8 !: 3D real workspace 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_9 !: 3D real workspace 104 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_10 !: 3D real workspace 105 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_11 !: 3D real workspace 106 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_12 !: 3D real workspace 107 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_13 !: 3D real workspace 108 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_14 !: 3D real workspace 109 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: wrk_3d_15 !: 3D real workspace 110 111 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:), PUBLIC :: wrk_4d_1, wrk_4d_2, wrk_4d_3, wrk_4d_4 !: 4D real workspace 112 113 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: wrk_xz_1, wrk_xz_2, wrk_xz_3, wrk_xz_4 !: 2D, x-z workspaces 114 115 LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: llwrk_2d_1, llwrk_2d_2, llwrk_2d_3 !: 2D logical workspace 116 LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: llwrk_3d_1 !: 3D logical workspace 117 118 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: iwrk_2d_1 !: 2D integer workspace 119 120 121 LOGICAL, DIMENSION(num_1d_wrkspaces) :: in_use_1d !: Flags to track which 1D workspace arrays are in use 122 LOGICAL, DIMENSION(num_2d_wrkspaces) :: in_use_2d !: Flags to track which 2D workspace arrays are in use 123 LOGICAL, DIMENSION(num_3d_wrkspaces) :: in_use_3d !: Flags to track which 3D workspace arrays are in use 124 LOGICAL, DIMENSION(num_4d_wrkspaces) :: in_use_4d !: Flags to track which 4D workspace arrays are in use 125 LOGICAL, DIMENSION(num_xz_wrkspaces) :: in_use_xz !: Flags to track which 2D, xz workspace arrays are in use 126 LOGICAL, DIMENSION(num_2d_lwrkspaces) :: in_use_2dll !: Flags to track which 2D, logical workspace arrays are in use 127 LOGICAL, DIMENSION(num_3d_lwrkspaces) :: in_use_3dll !: Flags to track which 3D, logical workspace arrays are in use 128 LOGICAL, DIMENSION(num_2d_iwrkspaces) :: in_use_2di !: Flags to track which 2D, integer workspace arrays are in use 42 ! !!** 1D, REAL(wp) workspaces ** 43 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_1 , wrk_1d_2 , wrk_1d_3 , wrk_1d_4 , wrk_1d_5 44 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_6 , wrk_1d_7 , wrk_1d_8 , wrk_1d_9 , wrk_1d_10 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_11, wrk_1d_12, wrk_1d_13, wrk_1d_14, wrk_1d_15 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_16, wrk_1d_17, wrk_1d_18, wrk_1d_19, wrk_1d_20 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_21, wrk_1d_22, wrk_1d_23, wrk_1d_24, wrk_1d_25 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) , TARGET, PUBLIC :: wrk_1d_26, wrk_1d_27 49 50 ! !!** 2D, x-y, REAL(wp) workspaces ** 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_1 , wrk_2d_2 , wrk_2d_3 , wrk_2d_4 , wrk_2d_5 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_6 , wrk_2d_7 , wrk_2d_8 , wrk_2d_9 , wrk_2d_10 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_11, wrk_2d_12, wrk_2d_13, wrk_2d_14, wrk_2d_15 54 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_16, wrk_2d_17, wrk_2d_18, wrk_2d_19, wrk_2d_20 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_21, wrk_2d_22, wrk_2d_23, wrk_2d_24, wrk_2d_25 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_26, wrk_2d_27, wrk_2d_28, wrk_2d_29, wrk_2d_30 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , TARGET, PUBLIC :: wrk_2d_31, wrk_2d_32, wrk_2d_33, wrk_2d_34, wrk_2d_35 58 59 ! !!** 2D, x-z, REAL(wp) workspaces ** 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: wrk_xz_1, wrk_xz_2, wrk_xz_3, wrk_xz_4 61 62 ! !!** 3D, x-y-z, REAL(wp) workspaces ** 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_1 , wrk_3d_2 , wrk_3d_3 , wrk_3d_4 , wrk_3d_5 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_6 , wrk_3d_7 , wrk_3d_8 , wrk_3d_9 , wrk_3d_10 65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: wrk_3d_11, wrk_3d_12, wrk_3d_13, wrk_3d_14, wrk_3d_15 66 67 ! !!** 4D, x-y-z-tra, REAL(wp) workspaces ** 68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:), TARGET, PUBLIC :: wrk_4d_1, wrk_4d_2, wrk_4d_3, wrk_4d_4 69 70 71 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: llwrk_2d_1, llwrk_2d_2, llwrk_2d_3 !: 2D logical workspace 72 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:,:) , TARGET, PUBLIC :: llwrk_3d_1 !: 3D logical workspace 73 INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) , PUBLIC :: iwrk_2d_1 !: 2D integer workspace 74 75 LOGICAL, DIMENSION(num_1d_wrkspaces) :: in_use_1d !: Flags to track which 1D workspace arrays are in use 76 LOGICAL, DIMENSION(num_2d_wrkspaces) :: in_use_2d !: Flags to track which 2D workspace arrays are in use 77 LOGICAL, DIMENSION(num_3d_wrkspaces) :: in_use_3d !: Flags to track which 3D workspace arrays are in use 78 LOGICAL, DIMENSION(num_4d_wrkspaces) :: in_use_4d !: Flags to track which 4D workspace arrays are in use 79 LOGICAL, DIMENSION(num_xz_wrkspaces) :: in_use_xz !: Flags to track which 2D, xz workspace arrays are in use 80 LOGICAL, DIMENSION(num_2d_lwrkspaces) :: in_use_2dll !: Flags to track which 2D, logical workspace arrays are in use 81 LOGICAL, DIMENSION(num_3d_lwrkspaces) :: in_use_3dll !: Flags to track which 3D, logical workspace arrays are in use 82 LOGICAL, DIMENSION(num_2d_iwrkspaces) :: in_use_2di !: Flags to track which 2D, integer workspace arrays are in use 129 83 130 84 ! Labels for specifying workspace type in call to print_in_use_list() … … 134 88 135 89 !!---------------------------------------------------------------------- 136 !! NEMO/OPA 4.0 , NEMO Consortium (201 0)90 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 137 91 !! $Id$ 138 92 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 140 94 CONTAINS 141 95 142 143 96 FUNCTION wrk_alloc() 144 97 !!---------------------------------------------------------------------- 145 !! *** ROUTINEwrk_alloc ***98 !! *** FUNCTION wrk_alloc *** 146 99 !! 147 100 !! ** Purpose : Define in memory once for all the NEMO 2D, 3D and 4d … … 153 106 !!---------------------------------------------------------------------- 154 107 ! 155 ! Extent to use for 1D work arrays - find the maximum product of 156 ! jpi*jpj, jpi*jpk and jpj*jpk and use that 157 IF(jpi < jpj .AND. jpi < jpk)THEN 158 extent_1d = jpj*jpk 159 ELSE IF(jpj < jpi .AND. jpj < jpk)THEN 160 extent_1d = jpi*jpk 161 ELSE 162 extent_1d = jpi*jpj 108 ! Extent to use for 1D work arrays - find the maximum product of jpi*jpj, jpi*jpk and jpj*jpk and use that 109 IF ( jpi < jpj .AND. jpi < jpk ) THEN ; extent_1d = jpj*jpk 110 ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN ; extent_1d = jpi*jpk 111 ELSE ; extent_1d = jpi*jpj 163 112 END IF 164 113 ! 165 114 ! Initialise the 'in use' flags for each work-space array 166 in_use_1d(:) = .FALSE. 167 168 in_use_2d(:) = .FALSE. 169 170 in_use_3d(:) = .FALSE. 171 172 in_use_4d(:) = .FALSE. 173 174 in_use_xz(:) = .FALSE. 175 115 in_use_1d (:) = .FALSE. 116 in_use_2d (:) = .FALSE. 117 in_use_3d (:) = .FALSE. 118 in_use_4d (:) = .FALSE. 119 in_use_xz (:) = .FALSE. 176 120 in_use_2dll(:) = .FALSE. 177 178 121 in_use_3dll(:) = .FALSE. 179 180 in_use_2di(:) = .FALSE. 181 122 in_use_2di (:) = .FALSE. 123 182 124 ierror(:) = 0 183 125 184 ALLOCATE(wrk_1d_1(extent_1d) , wrk_1d_2(extent_1d) , & 185 wrk_1d_3(extent_1d) , wrk_1d_4(extent_1d) , & 186 wrk_1d_5(extent_1d) , wrk_1d_6(extent_1d) , & 187 wrk_1d_7(extent_1d) , wrk_1d_8(extent_1d) , & 188 wrk_1d_9(extent_1d) , wrk_1d_10(extent_1d) , & 189 wrk_1d_11(extent_1d) , wrk_1d_12(extent_1d) , & 190 wrk_1d_13(extent_1d) , wrk_1d_14(extent_1d) , & 191 wrk_1d_15(extent_1d) , wrk_1d_16(extent_1d) , & 192 wrk_1d_17(extent_1d) , wrk_1d_18(extent_1d) , & 193 wrk_1d_19(extent_1d) , wrk_1d_20(extent_1d) , & 194 wrk_1d_21(extent_1d) , wrk_1d_22(extent_1d) , & 195 wrk_1d_23(extent_1d) , wrk_1d_24(extent_1d) , & 196 wrk_1d_25(extent_1d) , wrk_1d_26(extent_1d) , & 197 wrk_1d_27(extent_1d) , Stat=ierror(1)) 198 ! 199 ALLOCATE(wrk_2d_1(jpi,jpj) , wrk_2d_2(jpi,jpj) , & 200 wrk_2d_3(jpi,jpj) , wrk_2d_4(jpi,jpj) , & 201 wrk_2d_5(jpi,jpj) , wrk_2d_6(jpi,jpj) , & 202 wrk_2d_7(jpi,jpj) , wrk_2d_8(jpi,jpj) , & 203 wrk_2d_9(jpi,jpj) , wrk_2d_10(jpi,jpj) , & 204 wrk_2d_11(jpi,jpj) , wrk_2d_12(jpi,jpj) , & 205 wrk_2d_13(jpi,jpj) , wrk_2d_14(jpi,jpj) , & 206 wrk_2d_15(jpi,jpj) , wrk_2d_16(jpi,jpj) , & 207 wrk_2d_17(jpi,jpj) , wrk_2d_18(jpi,jpj) , & 208 wrk_2d_19(jpi,jpj) , wrk_2d_20(jpi,jpj) , & 209 wrk_2d_21(jpi,jpj) , wrk_2d_22(jpi,jpj) , & 210 wrk_2d_23(jpi,jpj) , wrk_2d_24(jpi,jpj) , & 211 wrk_2d_25(jpi,jpj) , wrk_2d_26(jpi,jpj) , & 212 wrk_2d_27(jpi,jpj) , wrk_2d_28(jpi,jpj) , & 213 wrk_2d_29(jpi,jpj) , wrk_2d_30(jpi,jpj) , & 214 wrk_2d_31(jpi,jpj) , wrk_2d_32(jpi,jpj) , & 215 wrk_2d_33(jpi,jpj) , wrk_2d_34(jpi,jpj) , & 216 wrk_2d_35(jpi,jpj) , Stat=ierror(2)) 217 ! 218 ALLOCATE(wrk_3d_1(jpi,jpj,jpk) , wrk_3d_2(jpi,jpj,jpk) , & 219 wrk_3d_3(jpi,jpj,jpk) , wrk_3d_4(jpi,jpj,jpk) , & 220 wrk_3d_5(jpi,jpj,jpk) , wrk_3d_6(jpi,jpj,jpk) , & 221 wrk_3d_7(jpi,jpj,jpk) , wrk_3d_8(jpi,jpj,jpk) , & 222 wrk_3d_9(jpi,jpj,jpk) , wrk_3d_10(jpi,jpj,jpk) , & 223 wrk_3d_11(jpi,jpj,jpk) , wrk_3d_12(jpi,jpj,jpk) , & 224 wrk_3d_13(jpi,jpj,jpk) , wrk_3d_14(jpi,jpj,jpk) , & 225 wrk_3d_15(jpi,jpj,jpk) , Stat=ierror(3)) 226 ! 227 ALLOCATE(wrk_4d_1(jpi,jpj,jpk,jpts) , wrk_4d_2(jpi,jpj,jpk,jpts), & 228 wrk_4d_3(jpi,jpj,jpk,jpts) , wrk_4d_4(jpi,jpj,jpk,jpts), & 229 Stat=ierror(4) ) 230 ! 231 ALLOCATE(wrk_xz_1(jpi,jpk) , wrk_xz_2(jpi,jpk), & 232 wrk_xz_3(jpi,jpk) , wrk_xz_4(jpi,jpk), & 233 Stat=ierror(5)) 234 ! 235 ALLOCATE(llwrk_2d_1(jpi,jpj) , llwrk_2d_2(jpi,jpj), & 236 llwrk_2d_3(jpi,jpj) , Stat=ierror(6)) 237 ! 238 ALLOCATE(llwrk_3d_1(jpi,jpj,jpk) , Stat=ierror(7)) 239 ! 240 ALLOCATE(iwrk_2d_1(jpi,jpj) , Stat=ierror(8)) 241 ! 242 wrk_alloc = MAXVAL(ierror) 126 ALLOCATE( wrk_1d_1 (extent_1d) , wrk_1d_2 (extent_1d) , wrk_1d_3 (extent_1d) , wrk_1d_4 (extent_1d) , & 127 & wrk_1d_5 (extent_1d) , wrk_1d_6 (extent_1d) , wrk_1d_7 (extent_1d) , wrk_1d_8 (extent_1d) , & 128 & wrk_1d_9 (extent_1d) , wrk_1d_10(extent_1d) , & 129 & wrk_1d_11(extent_1d) , wrk_1d_12(extent_1d) , wrk_1d_13(extent_1d) , wrk_1d_14(extent_1d) , & 130 & wrk_1d_15(extent_1d) , wrk_1d_16(extent_1d) , wrk_1d_17(extent_1d) , wrk_1d_18(extent_1d) , & 131 & wrk_1d_19(extent_1d) , wrk_1d_20(extent_1d) , & 132 & wrk_1d_21(extent_1d) , wrk_1d_22(extent_1d) , wrk_1d_23(extent_1d) , wrk_1d_24(extent_1d) , & 133 & wrk_1d_25(extent_1d) , wrk_1d_26(extent_1d) , wrk_1d_27(extent_1d) , STAT=ierror(1) ) 134 ! 135 ALLOCATE( wrk_2d_1 (jpi,jpj) , wrk_2d_2 (jpi,jpj) , wrk_2d_3 (jpi,jpj) , wrk_2d_4 (jpi,jpj) , & 136 & wrk_2d_5 (jpi,jpj) , wrk_2d_6 (jpi,jpj) , wrk_2d_7 (jpi,jpj) , wrk_2d_8 (jpi,jpj) , & 137 & wrk_2d_9 (jpi,jpj) , wrk_2d_10(jpi,jpj) , & 138 & wrk_2d_11(jpi,jpj) , wrk_2d_12(jpi,jpj) , wrk_2d_13(jpi,jpj) , wrk_2d_14(jpi,jpj) , & 139 & wrk_2d_15(jpi,jpj) , wrk_2d_16(jpi,jpj) , wrk_2d_17(jpi,jpj) , wrk_2d_18(jpi,jpj) , & 140 & wrk_2d_19(jpi,jpj) , wrk_2d_20(jpi,jpj) , & 141 & wrk_2d_21(jpi,jpj) , wrk_2d_22(jpi,jpj) , wrk_2d_23(jpi,jpj) , wrk_2d_24(jpi,jpj) , & 142 & wrk_2d_25(jpi,jpj) , wrk_2d_26(jpi,jpj) , wrk_2d_27(jpi,jpj) , wrk_2d_28(jpi,jpj) , & 143 & wrk_2d_29(jpi,jpj) , wrk_2d_30(jpi,jpj) , & 144 & wrk_2d_31(jpi,jpj) , wrk_2d_32(jpi,jpj) , wrk_2d_33(jpi,jpj) , wrk_2d_34(jpi,jpj) , & 145 & wrk_2d_35(jpi,jpj) , STAT=ierror(2) ) 146 ! 147 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) , & 148 & wrk_3d_5 (jpi,jpj,jpk) , wrk_3d_6 (jpi,jpj,jpk) , wrk_3d_7 (jpi,jpj,jpk) , wrk_3d_8 (jpi,jpj,jpk) , & 149 & wrk_3d_9 (jpi,jpj,jpk) , wrk_3d_10(jpi,jpj,jpk) , & 150 & wrk_3d_11(jpi,jpj,jpk) , wrk_3d_12(jpi,jpj,jpk) , wrk_3d_13(jpi,jpj,jpk) , wrk_3d_14(jpi,jpj,jpk) , & 151 & wrk_3d_15(jpi,jpj,jpk) , STAT=ierror(3) ) 152 ! 153 ALLOCATE( wrk_4d_1(jpi,jpj,jpk,jpts) , wrk_4d_2(jpi,jpj,jpk,jpts), & 154 & wrk_4d_3(jpi,jpj,jpk,jpts) , wrk_4d_4(jpi,jpj,jpk,jpts), STAT=ierror(4) ) 155 ! 156 ALLOCATE( wrk_xz_1(jpi,jpk) , wrk_xz_2(jpi,jpk) , wrk_xz_3(jpi,jpk) , wrk_xz_4(jpi,jpk) , STAT=ierror(5) ) 157 ! 158 ALLOCATE( llwrk_2d_1(jpi,jpj) , llwrk_2d_2(jpi,jpj) , llwrk_2d_3(jpi,jpj) , STAT=ierror(6) ) 159 ! 160 ALLOCATE( llwrk_3d_1(jpi,jpj,jpk) , STAT=ierror(7) ) 161 ! 162 ALLOCATE( iwrk_2d_1(jpi,jpj) , STAT=ierror(8) ) 163 ! 164 wrk_alloc = MAXVAL( ierror ) 243 165 244 166 ! Calling routine, nemo_alloc(), checks for errors and takes 245 167 ! appropriate action - we just print a warning message 246 IF(wrk_alloc /= 0)THEN 247 CALL ctl_warn('wrk_alloc: allocation of workspace arrays failed') 248 END IF 249 168 IF( wrk_alloc /= 0 ) CALL ctl_warn('wrk_alloc: allocation of workspace arrays failed') 169 ! 250 170 END FUNCTION wrk_alloc 251 171 252 172 253 FUNCTION wrk_use( ndim, index1, index2, index3, index4,&254 index5, index6, index7, index8, index9,&255 index10, index11, index12, index13, index14,&256 index15, index16, index17, index18, index19,&257 index20, index21, index22, index23, index24,&258 index25, index26, index27)259 !!---------------------------------------------------------------------- 260 !! *** ROUTINEwrk_use ***173 FUNCTION wrk_use( kdim, index1, index2, index3, index4, & 174 & index5, index6, index7, index8, index9, & 175 & index10, index11, index12, index13, index14, & 176 & index15, index16, index17, index18, index19, & 177 & index20, index21, index22, index23, index24, & 178 & index25, index26, index27) 179 !!---------------------------------------------------------------------- 180 !! *** FUNCTION wrk_use *** 261 181 !! 262 182 !! ** Purpose : Request a set of KIND(wp) workspaces to use. Returns 263 !! .TRUE. if all those requested are available, .FALSE. 264 !! otherwise. 265 !! 266 !! ** Method : Sets 267 !! internal flags to signal that requested workspaces 268 !! are in use. 269 !!---------------------------------------------------------------------- 270 IMPLICIT none 271 LOGICAL :: wrk_use ! Return value 272 INTEGER, INTENT(in) :: ndim ! Dimensionality of requested workspace(s) 273 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace 274 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 275 index6, index7, index8, index9, & 276 index10, index11, index12, index13, & 277 index14, index15, index16, index17, & 278 index18, index19, index20, index21, & 279 index22, index23, index24, index25, & 280 index26, index27 281 ! Local variables 282 INTEGER :: iarg, iptr 183 !! .TRUE. if all those requested are available, .FALSE. otherwise. 184 !! 185 !! ** Method : Sets internal flags to signal that requested workspaces are in use. 186 !!---------------------------------------------------------------------- 187 INTEGER, INTENT(in) :: kdim ! Dimensionality of requested workspace(s) 188 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace 189 INTEGER, OPTIONAL, INTENT(in) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9, index10 190 INTEGER, OPTIONAL, INTENT(in) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20 191 INTEGER, OPTIONAL, INTENT(in) :: index21, index22, index23, index24, index25, index26, index27 192 ! 193 LOGICAL :: wrk_use ! Return value 194 INTEGER :: iarg, iptr ! local integer 283 195 !!---------------------------------------------------------------------- 284 196 285 197 wrk_use = .TRUE. 286 287 iptr = index1 288 iarg = 1 289 DO WHILE(wrk_use .AND. iarg <= max_num_wrkspaces) 290 291 IF(ndim == 1)THEN 292 293 IF(iptr > num_1d_wrkspaces)THEN 198 iptr = index1 199 iarg = 1 200 201 DO WHILE( wrk_use .AND. iarg <= max_num_wrkspaces ) 202 ! 203 IF( kdim == 1 ) THEN 204 IF( iptr > num_1d_wrkspaces ) THEN 294 205 CALL ctl_stop('wrk_use - more 1D workspace arrays requested than defined in wrk_nemo module') 295 206 wrk_use = .FALSE. 296 207 EXIT 297 ELSE IF( in_use_1d(iptr) )THEN208 ELSEIF( in_use_1d(iptr) ) THEN 298 209 wrk_use = .FALSE. 299 210 CALL print_in_use_list(1, REAL_TYPE, in_use_1d) 300 END IF 301 211 ENDIF 302 212 in_use_1d(iptr) = .TRUE. 303 304 ELSE IF(ndim == 2)THEN 305 306 IF(iptr > num_2d_wrkspaces)THEN 213 ! 214 ELSEIF( kdim == 2 ) THEN 215 IF( iptr > num_2d_wrkspaces ) THEN 307 216 CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module') 308 217 wrk_use = .FALSE. 309 218 EXIT 310 ELSE IF( in_use_2d(iptr) )THEN219 ELSEIF( in_use_2d(iptr) ) THEN 311 220 wrk_use = .FALSE. 312 221 CALL print_in_use_list(2, REAL_TYPE, in_use_2d) 313 END IF 314 222 ENDIF 315 223 in_use_2d(iptr) = .TRUE. 316 317 ELSE IF (ndim == 3)THEN 318 319 IF(iptr > num_3d_wrkspaces)THEN 320 CALL ctl_stop('wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module') 224 ! 225 ELSEIF( kdim == 3 ) THEN 226 IF( iptr > num_3d_wrkspaces ) THEN 227 CALL ctl_stop( 'wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module' ) 321 228 wrk_use = .FALSE. 322 229 EXIT 323 ELSE IF( in_use_3d(iptr) )THEN230 ELSEIF( in_use_3d(iptr) ) THEN 324 231 wrk_use = .FALSE. 325 232 CALL print_in_use_list(3, REAL_TYPE, in_use_3d) 326 END IF 327 233 ENDIF 328 234 in_use_3d(iptr) = .TRUE. 329 330 ELSE IF (ndim == 4) THEN 331 235 ! 236 ELSEIF( kdim == 4 ) THEN 332 237 IF(iptr > num_4d_wrkspaces)THEN 333 CALL ctl_stop( 'wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module')238 CALL ctl_stop( 'wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module' ) 334 239 wrk_use = .FALSE. 335 240 EXIT 336 ELSE IF( in_use_4d(iptr) )THEN241 ELSEIF( in_use_4d(iptr) ) THEN 337 242 wrk_use = .FALSE. 338 CALL print_in_use_list( 4, REAL_TYPE, in_use_4d)339 END 340 243 CALL print_in_use_list( 4, REAL_TYPE, in_use_4d ) 244 ENDIF 245 ! 341 246 in_use_4d(iptr) = .TRUE. 342 247 ! 343 248 ELSE 344 IF(lwp) WRITE(numout,*) 'wrk_use: unsupported value of ndim = ',ndim345 CALL ctl_stop( 'wrk_use: unrecognised value for number of dimensions')249 IF(lwp) WRITE(numout,*) 'wrk_use: unsupported value of kdim = ',kdim 250 CALL ctl_stop( 'wrk_use: unrecognised value for number of dimensions' ) 346 251 END IF 347 252 348 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 349 index5, index6, index7, index8, index9, & 350 index10, index11, index12, index13, index14, & 351 index15, index16, index17, index18, index19, & 352 index20, index21, index22, index23, index24, & 353 index25, index26, index27) 354 355 IF(iarg == -1)THEN 356 ! We've checked all of the arguments and are done 357 EXIT 358 ELSE IF(iarg == -99)THEN 359 CALL ctl_stop('wrk_use - ERROR, caught unexpected argument count - BUG') 253 CALL get_next_arg( iarg , iptr , index2, index3, index4, & 254 & index5, index6, index7, index8, index9, & 255 & index10, index11, index12, index13, index14, & 256 & index15, index16, index17, index18, index19, & 257 & index20, index21, index22, index23, index24, & 258 & index25, index26, index27) 259 260 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 261 EXIT 262 ELSEIF( iarg == -99 ) THEN 263 CALL ctl_stop( 'wrk_use - ERROR, caught unexpected argument count - BUG' ) 360 264 EXIT 361 265 END IF 362 266 ! 363 267 END DO ! end of DO WHILE() 364 268 ! 365 269 END FUNCTION wrk_use 366 270 367 271 368 FUNCTION llwrk_use(ndim, index1, index2, index3, index4,&369 370 !!---------------------------------------------------------------------- 371 !! *** ROUTINEllwrk_use ***272 FUNCTION llwrk_use( kdim, index1, index2, index3, index4, & 273 & index5, index6, index7, index8, index9) 274 !!---------------------------------------------------------------------- 275 !! *** FUNCTION llwrk_use *** 372 276 !! 373 277 !! ** Purpose : Request a set of LOGICAL workspaces to use. Returns 374 !! .TRUE. if all those requested are available, .FALSE. 375 !! otherwise. 376 !! 377 !! ** Method : Sets 378 !! internal flags to signal that requested workspaces 379 !! are in use. 380 !!---------------------------------------------------------------------- 381 LOGICAL :: llwrk_use ! Return value 382 INTEGER, INTENT(in) :: ndim ! Dimensionality of requested workspace(s) 383 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace 384 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 385 index6, index7, index8, index9 386 ! Local variables 387 INTEGER :: iarg, iptr 388 !!---------------------------------------------------------------------- 389 278 !! .TRUE. if all those requested are available, .FALSE. otherwise. 279 !! 280 !! ** Method : Sets internal flags to signal that requested workspaces are in use. 281 !!---------------------------------------------------------------------- 282 INTEGER, INTENT(in) :: kdim ! Dimensionality of requested workspace(s) 283 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace 284 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9 285 ! 286 LOGICAL :: llwrk_use ! Return value 287 INTEGER :: iarg, iptr ! local integers 288 !!---------------------------------------------------------------------- 289 ! 390 290 llwrk_use = .TRUE. 391 392 iptr = index1 393 iarg = 1 394 DO WHILE(llwrk_use .AND. iarg <= max_num_wrkspaces) 395 396 IF(ndim == 2)THEN 397 291 iptr = index1 292 iarg = 1 293 ! 294 DO WHILE( llwrk_use .AND. iarg <= max_num_wrkspaces ) 295 ! 296 IF( kdim == 2 ) THEN 398 297 IF(iptr > num_2d_lwrkspaces)THEN 399 298 CALL ctl_stop('llwrk_use - more 2D workspace arrays requested than defined in wrk_nemo module') … … 404 303 CALL print_in_use_list(2, REAL_TYPE, in_use_2d) 405 304 END IF 406 407 305 in_use_2dll(iptr) = .TRUE. 408 409 ELSE IF ( ndim == 3)THEN410 306 ! 307 ELSE IF (kdim == 3)THEN 308 ! 411 309 IF(iptr > num_3d_lwrkspaces)THEN 412 310 CALL ctl_stop('llwrk_use - more 3D workspace arrays requested than defined in wrk_nemo module') … … 417 315 CALL print_in_use_list(3, REAL_TYPE, in_use_3d) 418 316 END IF 419 317 ! 420 318 in_use_3dll(iptr) = .TRUE. 421 319 ELSE 422 IF(lwp) WRITE(numout,*) 'llwrk_use: unsupported value of ndim = ',ndim320 IF(lwp) WRITE(numout,*) 'llwrk_use: unsupported value of kdim = ',kdim 423 321 CALL ctl_stop('llwrk_use: unrecognised value for number of dimensions') 424 322 END IF 425 323 426 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 427 index5, index6, index7, index8, index9) 428 429 IF(iarg == -1)THEN 430 ! We've checked all of the arguments and are done 431 EXIT 432 ELSE IF(iarg == -99)THEN 433 CALL ctl_stop('llwrk_use - ERROR, caught unexpected argument count - BUG') 434 EXIT 435 END IF 436 324 CALL get_next_arg( iarg , iptr , index2, index3, index4, & 325 & index5, index6, index7, index8, index9) 326 327 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 328 EXIT 329 ELSEIF( iarg == -99 ) THEN 330 CALL ctl_stop( 'llwrk_use - ERROR, caught unexpected argument count - BUG' ) 331 EXIT 332 ENDIF 333 ! 437 334 END DO ! while(llwrk_use .AND. iarg <= max_num_wrkspaces) 438 439 440 441 442 FUNCTION iwrk_use(ndim, index1, index2, index3, index4,&443 index5, index6, index7)444 !!---------------------------------------------------------------------- 445 !! *** ROUTINEiwrk_use ***335 ! 336 END FUNCTION llwrk_use 337 338 339 FUNCTION iwrk_use( kdim, index1, index2, index3, index4, & 340 & index5, index6, index7 ) 341 !!---------------------------------------------------------------------- 342 !! *** FUNCTION iwrk_use *** 446 343 !! 447 344 !! ** Purpose : Request a set of INTEGER workspaces to use. Returns 448 !! .TRUE. if all those requested are available, .FALSE. 449 !! otherwise. 450 !! 451 !! ** Method : Sets 452 !! internal flags to signal that requested workspaces 453 !! are in use. 454 !!---------------------------------------------------------------------- 345 !! .TRUE. if all those requested are available, .FALSE. otherwise. 346 !! 347 !! ** Method : Sets internal flags to signal that requested workspaces are in use. 348 !!---------------------------------------------------------------------- 349 INTEGER , INTENT(in) :: kdim ! Dimensionality of requested workspace(s) 350 INTEGER , INTENT(in) :: index1 ! Index of first requested workspace 351 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7 352 ! 455 353 LOGICAL :: iwrk_use ! Return value 456 INTEGER, INTENT(in) :: ndim ! Dimensionality of requested workspace(s)457 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace458 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &459 index6, index7460 ! Local variables461 354 INTEGER :: iarg, iptr 462 355 !!---------------------------------------------------------------------- 463 356 464 357 iwrk_use = .TRUE. 465 466 iptr = index1 467 iarg = 1 468 DO WHILE(iwrk_use .AND. iarg <= max_num_wrkspaces) 469 470 IF(ndim == 2)THEN 471 472 IF(iptr > num_2d_wrkspaces)THEN 473 CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module') 358 iptr = index1 359 iarg = 1 360 361 DO WHILE( iwrk_use .AND. iarg <= max_num_wrkspaces ) 362 ! 363 IF( kdim == 2 ) THEN 364 IF( iptr > num_2d_wrkspaces ) THEN 365 CALL ctl_stop( 'wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module' ) 474 366 iwrk_use = .FALSE. 475 ELSE IF( in_use_2di(iptr) )THEN367 ELSEIF( in_use_2di(iptr) ) THEN 476 368 iwrk_use = .FALSE. 477 CALL print_in_use_list(2, INTEGER_TYPE, in_use_2di) 478 END IF 479 369 CALL print_in_use_list( 2, INTEGER_TYPE, in_use_2di ) 370 END IF 480 371 in_use_2di(iptr) = .TRUE. 481 372 ! 482 373 ELSE 483 IF(lwp) WRITE(numout,*) 'iwrk_use: unsupported value of ndim = ',ndim374 IF(lwp) WRITE(numout,*) 'iwrk_use: unsupported value of kdim = ',kdim 484 375 CALL ctl_stop('iwrk_use: unsupported value for number of dimensions') 485 376 END IF … … 488 379 SELECT CASE (iarg) 489 380 CASE ( 1 ) 490 IF(.not. PRESENT(index2))THEN 491 EXIT 492 ELSE 493 iarg = 2 494 iptr = index2 381 IF( .NOT. PRESENT(index2) ) THEN ; EXIT 382 ELSE ; iarg = 2 ; iptr = index2 495 383 END IF 496 384 CASE ( 2 ) 497 IF(.not. PRESENT(index3))THEN 498 EXIT 499 ELSE 500 iarg = 3 501 iptr = index3 385 IF( .NOT. PRESENT(index3) ) THEN ; EXIT 386 ELSE ; iarg = 3 ; iptr = index3 502 387 END IF 503 388 CASE ( 3 ) 504 IF(.not. PRESENT(index4))THEN 505 EXIT 506 ELSE 507 iarg = 4 508 iptr = index4 389 IF( .NOT. PRESENT(index4) ) THEN ; EXIT 390 ELSE ; iarg = 4 ; iptr = index4 509 391 END IF 510 392 CASE ( 4 ) 511 IF(.not. PRESENT(index5))THEN 512 EXIT 513 ELSE 514 iarg = 5 515 iptr = index5 393 IF( .NOT. PRESENT(index5) ) THEN ; EXIT 394 ELSE ; iarg = 5 ; iptr = index5 516 395 END IF 517 396 CASE ( 5 ) 518 IF(.not. PRESENT(index6))THEN 519 EXIT 520 ELSE 521 iarg = 6 522 iptr = index6 397 IF( .NOT. PRESENT(index6) ) THEN ; EXIT 398 ELSE ; iarg = 6 ; iptr = index6 523 399 END IF 524 400 CASE ( 6 ) 525 IF(.not. PRESENT(index7))THEN 526 EXIT 527 ELSE 528 iarg = 7 529 iptr = index7 401 IF( .NOT. PRESENT(index7) ) THEN ; EXIT 402 ELSE ; iarg = 7 ; iptr = index7 530 403 END IF 531 404 CASE ( 7 ) 532 405 EXIT 533 406 CASE DEFAULT 534 CALL ctl_stop( 'iwrk_use - ERROR, caught unexpected argument count - BUG')407 CALL ctl_stop( 'iwrk_use - ERROR, caught unexpected argument count - BUG' ) 535 408 EXIT 536 409 END SELECT 537 410 ! 538 411 END DO ! end of DO WHILE() 539 412 ! 540 413 END FUNCTION iwrk_use 541 414 542 415 543 FUNCTION wrk_use_xz(index1, index2, index3, index4,&544 index5, index6, index7, index8, index9)545 !!---------------------------------------------------------------------- 546 !! *** ROUTINEwrk_use_xz ***416 FUNCTION wrk_use_xz( index1, index2, index3, index4, & 417 & index5, index6, index7, index8, index9 ) 418 !!---------------------------------------------------------------------- 419 !! *** FUNCTION wrk_use_xz *** 547 420 !! 548 421 !! ** Purpose : Request a set of 2D, xz (jpi,jpk) workspaces to use. … … 550 423 !! .FALSE. otherwise. 551 424 !! 552 !! ** Method : Sets 553 !! internal flags to signal that requested workspaces 554 !! are in use. 555 !!---------------------------------------------------------------------- 556 LOGICAL :: wrk_use_xz ! Return value 557 INTEGER, INTENT(in) :: index1 ! Index of first requested workspace 558 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 559 index6, index7, index8, index9 425 !! ** Method : Sets internal flags to signal that requested workspaces are in use. 426 !!---------------------------------------------------------------------- 427 INTEGER , INTENT(in) :: index1 ! Index of first requested workspace 428 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9 560 429 ! Local variables 430 LOGICAL :: wrk_use_xz ! Return value 431 INTEGER :: iarg, iptr ! local integer 432 !!---------------------------------------------------------------------- 433 434 wrk_use_xz = .TRUE. 435 iptr = index1 436 iarg = 1 437 438 DO WHILE( wrk_use_xz .AND. iarg <= max_num_wrkspaces ) 439 ! 440 IF(iptr > num_xz_wrkspaces)THEN 441 CALL ctl_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module') 442 wrk_use_xz = .FALSE. 443 EXIT 444 ELSE IF( in_use_xz(iptr) )THEN 445 wrk_use_xz = .FALSE. 446 CALL print_in_use_list(2, REAL_TYPE, in_use_xz) !ARPDBG - bug 447 END IF 448 ! 449 in_use_xz(iptr) = .TRUE. 450 ! 451 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 452 & index5, index6, index7, index8, index9) 453 ! 454 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 455 EXIT 456 ELSEIF( iarg == -99 ) THEN 457 CALL ctl_stop( 'wrk_use_xz - ERROR, caught unexpected argument count - BUG' ) ; EXIT 458 END IF 459 ! 460 END DO ! while(wrk_use_xz .AND. iarg <= max_num_wrkspaces) 461 ! 462 END FUNCTION wrk_use_xz 463 464 465 FUNCTION wrk_release( kdim, index1, index2, index3, index4, & 466 & index5, index6, index7, index8, index9, & 467 & index10, index11, index12, index13, index14, & 468 & index15, index16, index17, index18, index19, & 469 & index20, index21, index22, index23, index24, & 470 & index25, index26, index27) 471 !!---------------------------------------------------------------------- 472 !! *** FUNCTION wrk_release *** 473 !! 474 !! ** Purpose : Flag that the specified workspace arrays are no-longer in use. 475 !!---------------------------------------------------------------------- 476 LOGICAL :: wrk_release ! Return value 477 INTEGER, INTENT(in) :: kdim ! Dimensionality of workspace(s) 478 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 479 INTEGER, OPTIONAL, INTENT(in) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10 480 INTEGER, OPTIONAL, INTENT(in) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20 481 INTEGER, OPTIONAL, INTENT(in) :: index21, index22, index23, index24, index25, index26, index27 482 ! 561 483 INTEGER :: iarg, iptr 562 484 !!---------------------------------------------------------------------- 563 485 564 wrk_use_xz = .TRUE. 565 486 wrk_release = .TRUE. 566 487 iptr = index1 567 488 iarg = 1 568 DO WHILE(wrk_use_xz .AND. iarg <= max_num_wrkspaces) 569 570 IF(iptr > num_xz_wrkspaces)THEN 571 CALL ctl_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module') 572 wrk_use_xz = .FALSE. 489 490 DO WHILE( iarg <= max_num_wrkspaces ) 491 ! 492 IF( kdim == 1 ) THEN 493 IF( iptr > num_1d_wrkspaces ) THEN 494 CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 1D workspace array' ) 495 wrk_release = .FALSE. 496 ELSE 497 in_use_1d(iptr) = .FALSE. 498 ENDIF 499 ! 500 ELSE IF(kdim == 2)THEN 501 IF( iptr > num_2d_wrkspaces ) THEN 502 CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 2D workspace array' ) 503 wrk_release = .FALSE. 504 ENDIF 505 in_use_2d(iptr) = .FALSE. 506 ! 507 ELSEIF( kdim == 3 ) THEN 508 IF( iptr > num_3d_wrkspaces ) THEN 509 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 3D workspace array') 510 wrk_release = .FALSE. 511 END IF 512 in_use_3d(iptr) = .FALSE. 513 ! 514 ELSEIF( kdim == 4 ) THEN 515 IF(iptr > num_4d_wrkspaces)THEN 516 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 4D workspace array') 517 wrk_release = .FALSE. 518 END IF 519 in_use_4d(iptr) = .FALSE. 520 ! 521 ELSE 522 IF(lwp) WRITE(numout,*) 'wrk_release: unsupported value of kdim = ',kdim 523 CALL ctl_stop('wrk_release: unrecognised value for number of dimensions') 524 ENDIF 525 526 ! Move on to next optional argument 527 CALL get_next_arg( iarg , iptr , index2, index3, index4, & 528 & index5, index6, index7, index8, index9, & 529 & index10, index11, index12, index13, & 530 & index14, index15, index16, index17, & 531 & index18, index19, index20, index21, & 532 & index22, index23, index24, index25, & 533 & index26, index27 ) 534 535 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 536 EXIT 537 ELSEIF( iarg == -99 ) THEN 538 CALL ctl_stop('wrk_release - caught unexpected argument count - BUG') ; EXIT 539 END IF 540 ! 541 END DO ! end of DO WHILE() 542 ! 543 END FUNCTION wrk_release 544 545 546 FUNCTION llwrk_release( kdim, index1, index2, index3, index4, index5, & 547 & index6, index7, index8, index9 ) 548 !!---------------------------------------------------------------------- 549 !! *** FUNCTION wrk_release *** 550 !!---------------------------------------------------------------------- 551 INTEGER , INTENT(in) :: kdim ! Dimensionality of workspace(s) 552 INTEGER , INTENT(in) :: index1 ! Index of 1st workspace to release 553 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9 554 ! 555 LOGICAL :: llwrk_release ! Return value 556 INTEGER :: iarg, iptr ! local integer 557 !!---------------------------------------------------------------------- 558 ! 559 llwrk_release = .TRUE. 560 iptr = index1 561 iarg = 1 562 ! 563 DO WHILE(iarg <= max_num_wrkspaces) 564 ! 565 IF( kdim == 2 ) THEN 566 ! 567 IF( iptr > num_2d_lwrkspaces ) THEN 568 CALL ctl_stop( 'llwrk_release - ERROR - attempt to release a non-existant 2D workspace array' ) 569 llwrk_release = .FALSE. 573 570 EXIT 574 ELSE IF( in_use_xz(iptr) )THEN 575 wrk_use_xz = .FALSE. 576 CALL print_in_use_list(2, REAL_TYPE, in_use_xz) !ARPDBG - bug 577 END IF 578 579 in_use_xz(iptr) = .TRUE. 580 581 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 582 index5, index6, index7, index8, index9) 583 584 IF(iarg == -1)THEN 585 ! We've checked all of the arguments and are done 586 EXIT 587 ELSE IF(iarg == -99)THEN 588 CALL ctl_stop('wrk_use_xz - ERROR, caught unexpected argument count - BUG') 589 EXIT 571 ENDIF 572 in_use_2dll(iptr) = .FALSE. 573 ! 574 ELSEIF( kdim == 3 ) THEN 575 IF( iptr > num_3d_lwrkspaces ) THEN 576 CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 3D workspace array') 577 llwrk_release = .FALSE. 578 EXIT 579 ENDIF 580 in_use_3dll(iptr) = .FALSE. 581 ! 582 ELSE 583 IF(lwp) WRITE(numout,*) 'llwrk_release: unsupported value of kdim = ', kdim 584 CALL ctl_stop( 'llwrk_release: unrecognised value for number of dimensions' ) 590 585 END IF 591 592 END DO ! while(wrk_use_xz .AND. iarg <= max_num_wrkspaces) 593 594 END FUNCTION wrk_use_xz 595 596 597 FUNCTION wrk_release(ndim, index1, index2, index3, index4, & 598 index5, index6, index7, index8, index9, & 599 index10, index11, index12, index13, index14, & 600 index15, index16, index17, index18, index19, & 601 index20, index21, index22, index23, index24, & 602 index25, index26, index27) 603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE wrk_release *** 605 !! 606 !! ** Purpose : Flag that the specified workspace arrays are no-longer 607 !! in use. 608 !!---------------------------------------------------------------------- 609 LOGICAL :: wrk_release ! Return value 610 INTEGER, INTENT(in) :: ndim ! Dimensionality of workspace(s) 611 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 612 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 613 index6, index7, index8, index9, & 614 index10, index11, index12, index13, & 615 index14, index15, index16, index17, & 616 index18, index19, index20, index21, & 617 index22, index23, index24, index25, & 618 index26, index27 619 ! Local variables 620 INTEGER :: iarg, iptr 621 !!---------------------------------------------------------------------- 622 623 wrk_release = .TRUE. 624 iptr = index1 625 iarg = 1 626 627 DO WHILE(iarg <= max_num_wrkspaces) 628 629 IF(ndim == 1)THEN 630 631 IF(iptr > num_1d_wrkspaces)THEN 632 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 1D workspace array') 633 wrk_release = .FALSE. 634 ELSE 635 in_use_1d(iptr) = .FALSE. 636 END IF 637 638 ELSE IF(ndim == 2)THEN 639 640 IF(iptr > num_2d_wrkspaces)THEN 641 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 2D workspace array') 642 wrk_release = .FALSE. 643 END IF 644 645 in_use_2d(iptr) = .FALSE. 646 647 ELSE IF (ndim == 3)THEN 648 649 IF(iptr > num_3d_wrkspaces)THEN 650 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 3D workspace array') 651 wrk_release = .FALSE. 652 END IF 653 654 in_use_3d(iptr) = .FALSE. 655 656 ELSE IF (ndim == 4) THEN 657 658 IF(iptr > num_4d_wrkspaces)THEN 659 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 4D workspace array') 660 wrk_release = .FALSE. 661 END IF 662 663 in_use_4d(iptr) = .FALSE. 664 665 ELSE 666 IF(lwp) WRITE(numout,*) 'wrk_release: unsupported value of ndim = ',ndim 667 CALL ctl_stop('wrk_release: unrecognised value for number of dimensions') 668 END IF 669 670 ! Move on to next optional argument 671 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 672 index5, index6, index7, index8, index9, & 673 index10, index11, index12, index13, & 674 index14, index15, index16, index17, & 675 index18, index19, index20, index21, & 676 index22, index23, index24, index25, & 677 index26, index27) 678 679 IF(iarg == -1)THEN 680 ! We've checked all of the arguments and are done 586 ! 587 ! Move on to next optional argument 588 CALL get_next_arg(iarg, iptr, index2, index3, index4, & 589 & index5, index6, index7, index8, index9) 590 ! 591 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 681 592 EXIT 682 ELSE IF(iarg == -99)THEN 683 CALL ctl_stop('wrk_release - caught unexpected argument count - BUG') 684 EXIT 685 END IF 686 593 ELSEIF( iarg == -99 ) THEN 594 CALL ctl_stop( 'llwrk_release - ERROR, caught unexpected argument count - BUG' ) ; EXIT 595 ENDIF 596 ! 597 END DO ! while (iarg <= max_num_wrkspaces) 598 ! 599 END FUNCTION llwrk_release 600 601 602 FUNCTION iwrk_release( kdim, index1, index2, index3, index4, & 603 & index5, index6, index7 ) 604 !!---------------------------------------------------------------------- 605 !! *** FUNCTION iwrk_release *** 606 !! 607 !! ** Purpose : Flag that the specified INTEGER workspace arrays are 608 !! no-longer in use. 609 !!---------------------------------------------------------------------- 610 INTEGER, INTENT(in) :: kdim ! Dimensionality of workspace(s) 611 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 612 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7 613 ! 614 LOGICAL :: iwrk_release ! Return value 615 INTEGER :: iarg, iptr ! local integer 616 !!---------------------------------------------------------------------- 617 ! 618 iwrk_release = .TRUE. 619 iptr = index1 620 iarg = 1 621 ! 622 DO WHILE(iarg <= max_num_wrkspaces) 623 ! 624 IF( kdim == 2 ) THEN 625 IF( iptr > num_2d_iwrkspaces ) THEN 626 CALL ctl_stop('iwrk_release - ERROR - attempt to release a non-existant 2D workspace array') 627 iwrk_release = .FALSE. 628 ENDIF 629 in_use_2di(iptr) = .FALSE. 630 ELSE 631 IF(lwp) WRITE(numout,*) 'iwrk_release: unsupported value of kdim = ',kdim 632 CALL ctl_stop('iwrk_release: unsupported value for number of dimensions') 633 ENDIF 634 ! 635 ! Move on to next optional argument 636 SELECT CASE (iarg) 637 CASE ( 1 ) 638 IF( .NOT. PRESENT(index2) ) THEN ; EXIT 639 ELSE ; iarg = 2 ; iptr = index2 640 END IF 641 CASE ( 2 ) 642 IF( .NOT. PRESENT(index3) ) THEN ; EXIT 643 ELSE ; iarg = 3 ; iptr = index3 644 END IF 645 CASE ( 3 ) 646 IF( .NOT. PRESENT(index4) ) THEN ; EXIT 647 ELSE ; iarg = 4 ; iptr = index4 648 END IF 649 CASE ( 4 ) 650 IF( .NOT. PRESENT(index5) ) THEN ; EXIT 651 ELSE ; iarg = 5 ; iptr = index5 652 END IF 653 CASE ( 5 ) 654 IF( .NOT. PRESENT(index6) ) THEN ; EXIT 655 ELSE ; iarg = 6 ; iptr = index6 656 END IF 657 CASE ( 6 ) 658 IF( .NOT. PRESENT(index7) ) THEN ; EXIT 659 ELSE ; iarg = 7 ; iptr = index7 660 END IF 661 CASE ( 7 ) 662 EXIT 663 CASE DEFAULT 664 CALL ctl_stop( 'iwrk_release - ERROR, caught unexpected argument count - BUG' ) 665 EXIT 666 END SELECT 667 ! 687 668 END DO ! end of DO WHILE() 688 689 END FUNCTION wrk_release 690 691 692 FUNCTION llwrk_release(ndim, index1, index2, index3, index4, index5, & 693 index6, index7, index8, index9) 694 LOGICAL :: llwrk_release ! Return value 695 INTEGER, INTENT(in) :: ndim ! Dimensionality of workspace(s) 696 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 697 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 698 index6, index7, index8, index9 699 ! Local variables 700 INTEGER :: iarg, iptr 701 !!---------------------------------------------------------------------- 702 703 llwrk_release = .TRUE. 704 iptr = index1 705 iarg = 1 706 707 DO WHILE(iarg <= max_num_wrkspaces) 708 709 IF(ndim == 2)THEN 710 711 IF(iptr > num_2d_lwrkspaces)THEN 712 CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 2D workspace array') 713 llwrk_release = .FALSE. 714 EXIT 715 END IF 716 717 in_use_2dll(iptr) = .FALSE. 718 719 ELSE IF (ndim == 3)THEN 720 721 IF(iptr > num_3d_lwrkspaces)THEN 722 CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 3D workspace array') 723 llwrk_release = .FALSE. 724 EXIT 725 END IF 726 727 in_use_3dll(iptr) = .FALSE. 728 729 ELSE 730 IF(lwp) WRITE(numout,*) 'llwrk_release: unsupported value of ndim = ',ndim 731 CALL ctl_stop('llwrk_release: unrecognised value for number of dimensions') 732 END IF 733 734 ! Move on to next optional argument 735 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 736 index5, index6, index7, index8, index9) 737 738 IF(iarg == -1)THEN 739 ! We've checked all of the arguments and are done 740 EXIT 741 ELSE IF(iarg == -99)THEN 742 CALL ctl_stop('llwrk_release - ERROR, caught unexpected argument count - BUG') 743 EXIT 744 END IF 745 746 END DO ! while (iarg <= max_num_wrkspaces) 747 748 END FUNCTION llwrk_release 749 750 751 FUNCTION iwrk_release(ndim, index1, index2, index3, index4, index5, & 752 index6, index7) 753 !!---------------------------------------------------------------------- 754 !! *** ROUTINE iwrk_release *** 755 !! 756 !! ** Purpose : Flag that the specified INTEGER workspace arrays are 757 !! no-longer in use. 758 !!---------------------------------------------------------------------- 759 LOGICAL :: iwrk_release ! Return value 760 INTEGER, INTENT(in) :: ndim ! Dimensionality of workspace(s) 761 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 762 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 763 index6, index7 764 ! Local variables 765 INTEGER :: iarg, iptr 766 !!---------------------------------------------------------------------- 767 768 iwrk_release = .TRUE. 769 iptr = index1 770 iarg = 1 771 772 DO WHILE(iarg <= max_num_wrkspaces) 773 774 IF(ndim == 2)THEN 775 776 IF(iptr > num_2d_iwrkspaces)THEN 777 CALL ctl_stop('iwrk_release - ERROR - attempt to release a non-existant 2D workspace array') 778 iwrk_release = .FALSE. 779 END IF 780 781 in_use_2di(iptr) = .FALSE. 782 ELSE 783 IF(lwp) WRITE(numout,*) 'iwrk_release: unsupported value of ndim = ',ndim 784 CALL ctl_stop('iwrk_release: unsupported value for number of dimensions') 785 END IF 786 787 ! Move on to next optional argument 788 SELECT CASE (iarg) 789 CASE ( 1 ) 790 IF(.not. PRESENT(index2))THEN 791 EXIT 792 ELSE 793 iarg = 2 794 iptr = index2 795 END IF 796 CASE ( 2 ) 797 IF(.not. PRESENT(index3))THEN 798 EXIT 799 ELSE 800 iarg = 3 801 iptr = index3 802 END IF 803 CASE ( 3 ) 804 IF(.not. PRESENT(index4))THEN 805 EXIT 806 ELSE 807 iarg = 4 808 iptr = index4 809 END IF 810 CASE ( 4 ) 811 IF(.not. PRESENT(index5))THEN 812 EXIT 813 ELSE 814 iarg = 5 815 iptr = index5 816 END IF 817 CASE ( 5 ) 818 IF(.not. PRESENT(index6))THEN 819 EXIT 820 ELSE 821 iarg = 6 822 iptr = index6 823 END IF 824 CASE ( 6 ) 825 IF(.not. PRESENT(index7))THEN 826 EXIT 827 ELSE 828 iarg = 7 829 iptr = index7 830 END IF 831 CASE ( 7 ) 832 EXIT 833 CASE DEFAULT 834 CALL ctl_stop('iwrk_release - ERROR, caught unexpected argument count - BUG') 835 EXIT 836 END SELECT 837 838 END DO ! end of DO WHILE() 839 840 END FUNCTION iwrk_release 841 842 843 FUNCTION wrk_release_xz(index1, index2, index3, index4, index5, & 844 index6, index7, index8, index9) 845 LOGICAL :: wrk_release_xz ! Return value 846 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 847 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 848 index6, index7, index8, index9 849 ! Local variables 850 INTEGER :: iarg, iptr 851 !!---------------------------------------------------------------------- 852 853 wrk_release_xz = .TRUE. 854 iptr = index1 855 iarg = 1 856 857 DO WHILE(iarg <= max_num_wrkspaces) 858 859 IF(iptr > num_xz_wrkspaces)THEN 860 CALL ctl_stop('wrk_release_xz - ERROR - attempt to release a non-existant 2D xz workspace array') 861 wrk_release_xz = .FALSE. 862 EXIT 863 END IF 864 865 in_use_xz(iptr) = .FALSE. 866 867 868 ! Move on to next optional argument 869 CALL get_next_arg(iarg , iptr , index2, index3, index4, & 870 index5, index6, index7, index8, index9) 871 872 IF(iarg == -1)THEN 873 ! We've checked all of the arguments and are done 874 EXIT 875 ELSE IF(iarg == -99)THEN 876 CALL ctl_stop('wrk_release_xz - ERROR, caught unexpected argument count - BUG') 877 EXIT 878 END IF 879 880 END DO ! while (iarg <= max_num_wrkspaces) 881 882 END FUNCTION wrk_release_xz 883 884 885 SUBROUTINE print_in_use_list(ndim, itype, in_use_list) 886 !!---------------------------------------------------------------------- 887 !! *** routine print_in_use_list *** 888 !! 889 !! Purpose: to print out the table holding which workspace arrays 890 !! are currently marked as in use. 891 !!---------------------------------------------------------------------- 892 IMPLICIT none 893 INTEGER, INTENT(in) :: ndim 894 INTEGER, INTENT(in) :: itype 895 LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list 896 ! Locals 897 INTEGER :: ii, icount 898 CHARACTER(LEN=7) :: type_string 899 !!---------------------------------------------------------------------- 900 901 IF(.NOT. lwp) RETURN 902 903 SELECT CASE (ndim) 904 905 CASE (1) 906 907 SELECT CASE (itype) 908 909 CASE (INTEGER_TYPE) 910 icount = num_1d_iwrkspaces 911 CASE (LOGICAL_TYPE) 912 icount = num_1d_lwrkspaces 913 CASE (REAL_TYPE) 914 icount = num_1d_wrkspaces 915 END SELECT 916 917 CASE (2) 918 919 SELECT CASE (itype) 920 921 CASE (INTEGER_TYPE) 922 icount = num_2d_iwrkspaces 923 CASE (LOGICAL_TYPE) 924 icount = num_2d_lwrkspaces 925 CASE (REAL_TYPE) 926 icount = num_2d_wrkspaces 927 END SELECT 928 929 CASE (3) 930 931 SELECT CASE (itype) 932 933 CASE (INTEGER_TYPE) 934 icount = num_3d_iwrkspaces 935 CASE (LOGICAL_TYPE) 936 icount = num_3d_lwrkspaces 937 CASE (REAL_TYPE) 938 icount = num_3d_wrkspaces 939 END SELECT 940 941 CASE (4) 942 SELECT CASE (itype) 943 944 CASE (INTEGER_TYPE) 945 icount = num_4d_iwrkspaces 946 CASE (LOGICAL_TYPE) 947 icount = num_4d_lwrkspaces 948 CASE (REAL_TYPE) 949 icount = num_4d_wrkspaces 950 END SELECT 951 952 CASE DEFAULT 953 RETURN 954 955 END SELECT 956 957 ! Set character string with type of workspace 958 SELECT CASE (itype) 959 960 CASE (INTEGER_TYPE) 961 type_string = "INTEGER" 962 CASE (LOGICAL_TYPE) 963 type_string = "LOGICAL" 964 CASE (REAL_TYPE) 965 type_string = "REAL" 966 END SELECT 967 968 WRITE(numout,*) 969 WRITE(numout,"('------------------------------------------')") 970 WRITE(numout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") ndim, TRIM(type_string) 971 WRITE(numout,"('Workspace In use')") 972 DO ii=1,icount, 1 973 WRITE(numout,"(4x,I2,8x,L1)") ii, in_use_list(ii) 974 END DO 975 WRITE(numout,"('------------------------------------------')") 976 WRITE(numout,*) 977 978 END SUBROUTINE print_in_use_list 979 980 981 SUBROUTINE get_next_arg(iargidx, iargval, index2, index3, index4, & 982 index5 , index6, index7, index8, index9, & 983 index10, index11, index12, index13, index14, & 984 index15, index16, index17, index18, index19, & 985 index20, index21, index22, index23, index24, & 986 index25, index26, index27) 987 !!---------------------------------------------------------------------- 988 INTEGER, INTENT(inout) :: iargidx ! Index of current arg 989 INTEGER, INTENT(inout) :: iargval ! Value of current arg 990 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, & 991 index6, index7, index8, index9, & 992 index10, index11, index12, index13, & 993 index14, index15, index16, index17, & 994 index18, index19, index20, index21, & 995 index22, index23, index24, index25, & 996 index26, index27 997 !!---------------------------------------------------------------------- 998 999 ! Move on to next optional argument 1000 SELECT CASE (iargidx) 1001 CASE ( 1 ) 1002 IF(.not. PRESENT(index2))THEN 1003 iargidx = -1 1004 ELSE 1005 iargidx = 2 1006 iargval = index2 1007 END IF 1008 CASE ( 2 ) 1009 IF(.not. PRESENT(index3))THEN 1010 iargidx = -1 1011 ELSE 1012 iargidx = 3 1013 iargval = index3 1014 END IF 1015 CASE ( 3 ) 1016 IF(.not. PRESENT(index4))THEN 1017 iargidx = -1 1018 ELSE 1019 iargidx = 4 1020 iargval = index4 1021 END IF 1022 CASE ( 4 ) 1023 IF(.not. PRESENT(index5))THEN 1024 iargidx = -1 1025 ELSE 1026 iargidx = 5 1027 iargval = index5 1028 END IF 1029 CASE ( 5 ) 1030 IF(.not. PRESENT(index6))THEN 1031 iargidx = -1 1032 ELSE 1033 iargidx = 6 1034 iargval = index6 1035 END IF 1036 CASE ( 6 ) 1037 IF(.not. PRESENT(index7))THEN 1038 iargidx = -1 1039 ELSE 1040 iargidx = 7 1041 iargval = index7 1042 END IF 1043 CASE ( 7 ) 1044 IF(.not. PRESENT(index8))THEN 1045 iargidx = -1 1046 ELSE 1047 iargidx = 8 1048 iargval = index8 1049 END IF 1050 CASE ( 8 ) 1051 IF(.not. PRESENT(index9))THEN 1052 iargidx = -1 1053 ELSE 1054 iargidx = 9 1055 iargval = index9 1056 END IF 1057 CASE ( 9 ) 1058 IF(.not. PRESENT(index10))THEN 1059 iargidx = -1 1060 ELSE 1061 iargidx = 10 1062 iargval = index10 1063 END IF 1064 CASE ( 10 ) 1065 IF(.not. PRESENT(index11))THEN 1066 iargidx = -1 1067 ELSE 1068 iargidx = 11 1069 iargval = index11 1070 END IF 1071 CASE ( 11 ) 1072 IF(.not. PRESENT(index12))THEN 1073 iargidx = -1 1074 ELSE 1075 iargidx = 12 1076 iargval = index12 1077 END IF 1078 CASE ( 12 ) 1079 IF(.not. PRESENT(index13))THEN 1080 iargidx = -1 1081 ELSE 1082 iargidx = 13 1083 iargval = index13 1084 END IF 1085 CASE ( 13 ) 1086 IF(.not. PRESENT(index14))THEN 1087 iargidx = -1 1088 ELSE 1089 iargidx = 14 1090 iargval = index14 1091 END IF 1092 CASE ( 14 ) 1093 IF(.not. PRESENT(index15))THEN 1094 iargidx = -1 1095 ELSE 1096 iargidx = 15 1097 iargval = index15 1098 END IF 1099 CASE ( 15 ) 1100 IF(.not. PRESENT(index16))THEN 1101 iargidx = -1 1102 ELSE 1103 iargidx = 16 1104 iargval = index16 1105 END IF 1106 CASE ( 16 ) 1107 IF(.not. PRESENT(index17))THEN 1108 iargidx = -1 1109 ELSE 1110 iargidx = 17 1111 iargval = index17 1112 END IF 1113 CASE ( 17 ) 1114 IF(.not. PRESENT(index18))THEN 1115 iargidx = -1 1116 ELSE 1117 iargidx = 18 1118 iargval = index18 1119 END IF 1120 CASE ( 18 ) 1121 IF(.not. PRESENT(index19))THEN 1122 iargidx = -1 1123 ELSE 1124 iargidx = 19 1125 iargval = index19 1126 END IF 1127 CASE ( 19 ) 1128 IF(.not. PRESENT(index20))THEN 1129 iargidx = -1 1130 ELSE 1131 iargidx = 20 1132 iargval = index20 1133 END IF 1134 CASE ( 20 ) 1135 IF(.not. PRESENT(index21))THEN 1136 iargidx = -1 1137 ELSE 1138 iargidx = 21 1139 iargval = index21 1140 END IF 1141 CASE ( 21 ) 1142 IF(.not. PRESENT(index22))THEN 1143 iargidx = -1 1144 ELSE 1145 iargidx = 22 1146 iargval = index22 1147 END IF 1148 CASE ( 22 ) 1149 IF(.not. PRESENT(index23))THEN 1150 iargidx = -1 1151 ELSE 1152 iargidx = 23 1153 iargval = index23 1154 END IF 1155 CASE ( 23 ) 1156 IF(.not. PRESENT(index24))THEN 1157 iargidx = -1 1158 ELSE 1159 iargidx = 24 1160 iargval = index24 1161 END IF 1162 CASE ( 24 ) 1163 IF(.not. PRESENT(index25))THEN 1164 iargidx = -1 1165 ELSE 1166 iargidx = 25 1167 iargval = index25 1168 END IF 1169 CASE ( 25 ) 1170 IF(.not. PRESENT(index26))THEN 1171 iargidx = -1 1172 ELSE 1173 iargidx = 26 1174 iargval = index26 1175 END IF 1176 CASE ( 26 ) 1177 IF(.not. PRESENT(index27))THEN 1178 iargidx = -1 1179 ELSE 1180 iargidx = 27 1181 iargval = index27 1182 END IF 1183 CASE ( 27 ) 1184 iargidx = -1 1185 CASE DEFAULT 1186 ! BUG - iargidx shouldn't take any other values! 1187 ! Flag error for calling routine 1188 iargidx = -99 1189 END SELECT 1190 1191 END SUBROUTINE get_next_arg 1192 1193 669 ! 670 END FUNCTION iwrk_release 671 672 673 FUNCTION wrk_release_xz( index1, index2, index3, index4, index5, & 674 & index6, index7, index8, index9 ) 675 !!---------------------------------------------------------------------- 676 !! *** FUNCTION wrk_release_xz *** 677 !! 678 !!---------------------------------------------------------------------- 679 INTEGER, INTENT(in) :: index1 ! Index of 1st workspace to release 680 INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9 681 ! 682 LOGICAL :: wrk_release_xz ! Return value 683 INTEGER :: iarg, iptr ! local integer 684 !!---------------------------------------------------------------------- 685 ! 686 wrk_release_xz = .TRUE. 687 iptr = index1 688 iarg = 1 689 ! 690 DO WHILE( iarg <= max_num_wrkspaces ) 691 ! 692 IF( iptr > num_xz_wrkspaces ) THEN 693 CALL ctl_stop('wrk_release_xz - ERROR - attempt to release a non-existant 2D xz workspace array') 694 wrk_release_xz = .FALSE. 695 EXIT 696 ENDIF 697 in_use_xz(iptr) = .FALSE. 698 ! 699 ! Move on to next optional argument 700 CALL get_next_arg( iarg, iptr, index2, index3, index4, & 701 & index5, index6, index7, index8, index9) 702 ! 703 IF( iarg == -1 ) THEN ! We've checked all of the arguments and are done 704 EXIT 705 ELSEIF( iarg == -99 ) THEN 706 CALL ctl_stop('wrk_release_xz - ERROR, caught unexpected argument count - BUG') 707 EXIT 708 END IF 709 ! 710 END DO ! while (iarg <= max_num_wrkspaces) 711 ! 712 END FUNCTION wrk_release_xz 713 714 715 SUBROUTINE print_in_use_list( kdim, itype, in_use_list ) 716 !!---------------------------------------------------------------------- 717 !! *** ROUTINE print_in_use_list *** 718 !! 719 !! Purpose: to print out the table holding which workspace arrays 720 !! are currently marked as in use. 721 !!---------------------------------------------------------------------- 722 INTEGER, INTENT(in) :: kdim 723 INTEGER, INTENT(in) :: itype 724 LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list 725 ! 726 INTEGER :: ji, icount 727 CHARACTER(LEN=7) :: type_string 728 !!---------------------------------------------------------------------- 729 730 IF(.NOT. lwp) RETURN 731 732 SELECT CASE ( kdim ) 733 ! 734 CASE (1) 735 SELECT CASE (itype) 736 CASE (INTEGER_TYPE) ; icount = num_1d_iwrkspaces 737 CASE (LOGICAL_TYPE) ; icount = num_1d_lwrkspaces 738 CASE (REAL_TYPE ) ; icount = num_1d_wrkspaces 739 END SELECT 740 ! 741 CASE (2) 742 SELECT CASE (itype) 743 CASE (INTEGER_TYPE) ; icount = num_2d_iwrkspaces 744 CASE (LOGICAL_TYPE) ; icount = num_2d_lwrkspaces 745 CASE (REAL_TYPE ) ; icount = num_2d_wrkspaces 746 END SELECT 747 ! 748 CASE (3) 749 SELECT CASE (itype) 750 CASE (INTEGER_TYPE) ; icount = num_3d_iwrkspaces 751 CASE (LOGICAL_TYPE) ; icount = num_3d_lwrkspaces 752 CASE (REAL_TYPE ) ; icount = num_3d_wrkspaces 753 END SELECT 754 ! 755 CASE (4) 756 SELECT CASE (itype) 757 CASE (INTEGER_TYPE) ; icount = num_4d_iwrkspaces 758 CASE (LOGICAL_TYPE) ; icount = num_4d_lwrkspaces 759 CASE (REAL_TYPE ) ; icount = num_4d_wrkspaces 760 END SELECT 761 ! 762 CASE DEFAULT ; RETURN 763 ! 764 END SELECT 765 766 ! Set character string with type of workspace 767 SELECT CASE (itype) 768 CASE (INTEGER_TYPE) ; type_string = "INTEGER" 769 CASE (LOGICAL_TYPE) ; type_string = "LOGICAL" 770 CASE (REAL_TYPE ) ; type_string = "REAL" 771 END SELECT 772 773 WRITE(numout,*) 774 WRITE(numout,"('------------------------------------------')") 775 WRITE(numout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string) 776 WRITE(numout,"('Workspace In use')") 777 DO ji = 1, icount, 1 778 WRITE(numout,"(4x,I2,8x,L1)") ji, in_use_list(ji) 779 END DO 780 WRITE(numout,"('------------------------------------------')") 781 WRITE(numout,*) 782 ! 783 END SUBROUTINE print_in_use_list 784 785 786 SUBROUTINE get_next_arg( iargidx, iargval, index2, index3, index4, & 787 & index5 , index6, index7, index8, index9, & 788 & index10, index11, index12, index13, index14, & 789 & index15, index16, index17, index18, index19, & 790 & index20, index21, index22, index23, index24, & 791 & index25, index26, index27 ) 792 !!---------------------------------------------------------------------- 793 INTEGER, INTENT(inout) :: iargidx ! Index of current arg 794 INTEGER, INTENT(inout) :: iargval ! Value of current arg 795 INTEGER, OPTIONAL, INTENT(in) :: index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10 796 INTEGER, OPTIONAL, INTENT(in) :: index11, index12, index13, index14, index15, index16, index17, index18, index19, index20 797 INTEGER, OPTIONAL, INTENT(in) :: index21, index22, index23, index24, index25, index26, index27 798 !!---------------------------------------------------------------------- 799 800 SELECT CASE (iargidx) ! Move on to next optional argument 801 CASE ( 1 ) 802 IF( .NOT. PRESENT(index2 ) ) THEN ; iargidx = -1 803 ELSE ; iargidx = 2 ; iargval = index2 804 ENDIF 805 CASE ( 2 ) 806 IF( .NOT. PRESENT(index3 ) ) THEN ; iargidx = -1 807 ELSE ; iargidx = 3 ; iargval = index3 808 ENDIF 809 CASE ( 3 ) 810 IF( .NOT. PRESENT(index4 ) ) THEN ; iargidx = -1 811 ELSE ; iargidx = 4 ; iargval = index4 812 ENDIF 813 CASE ( 4 ) 814 IF( .NOT. PRESENT(index5 ) ) THEN ; iargidx = -1 815 ELSE ; iargidx = 5 ; iargval = index5 816 ENDIF 817 CASE ( 5 ) 818 IF( .NOT. PRESENT(index6 ) ) THEN ; iargidx = -1 819 ELSE ; iargidx = 6 ; iargval = index6 820 ENDIF 821 CASE ( 6 ) 822 IF( .NOT. PRESENT(index7 ) ) THEN ; iargidx = -1 823 ELSE ; iargidx = 7 ; iargval = index7 824 ENDIF 825 CASE ( 7 ) 826 IF( .NOT. PRESENT(index8 ) ) THEN ; iargidx = -1 827 ELSE ; iargidx = 8 ; iargval = index8 828 ENDIF 829 CASE ( 8 ) 830 IF( .NOT. PRESENT(index2 ) ) THEN ; iargidx = -1 831 ELSE ; iargidx = 9 ; iargval = index9 832 ENDIF 833 CASE ( 9 ) 834 IF( .NOT. PRESENT(index10) ) THEN ; iargidx = -1 835 ELSE ; iargidx = 10 ; iargval = index10 836 ENDIF 837 CASE ( 10 ) 838 IF( .NOT. PRESENT(index11) ) THEN ; iargidx = -1 839 ELSE ; iargidx = 11 ; iargval = index11 840 ENDIF 841 CASE ( 11 ) 842 IF( .NOT. PRESENT(index12) ) THEN ; iargidx = -1 843 ELSE ; iargidx = 12 ; iargval = index12 844 ENDIF 845 CASE ( 12 ) 846 IF( .NOT. PRESENT(index13) ) THEN ; iargidx = -1 847 ELSE ; iargidx = 13 ; iargval = index13 848 ENDIF 849 CASE ( 13 ) 850 IF( .NOT. PRESENT(index14) ) THEN ; iargidx = -1 851 ELSE ; iargidx = 14 ; iargval = index14 852 ENDIF 853 CASE ( 14 ) 854 IF( .NOT. PRESENT(index15) ) THEN ; iargidx = -1 855 ELSE ; iargidx = 15 ; iargval = index15 856 ENDIF 857 CASE ( 15 ) 858 IF( .NOT. PRESENT(index16) ) THEN ; iargidx = -1 859 ELSE ; iargidx = 16 ; iargval = index16 860 ENDIF 861 CASE ( 16 ) 862 IF( .NOT. PRESENT(index17) ) THEN ; iargidx = -1 863 ELSE ; iargidx = 17 ; iargval = index17 864 END IF 865 CASE ( 17 ) 866 IF( .NOT. PRESENT(index18) ) THEN ; iargidx = -1 867 ELSE ; iargidx = 18 ; iargval = index18 868 ENDIF 869 CASE ( 18 ) 870 IF( .NOT. PRESENT(index19) ) THEN ; iargidx = -1 871 ELSE ; iargidx = 19 ; iargval = index19 872 ENDIF 873 CASE ( 19 ) 874 IF( .NOT. PRESENT(index20) ) THEN ; iargidx = -1 875 ELSE ; iargidx = 20 ; iargval = index20 876 ENDIF 877 CASE ( 20 ) 878 IF( .NOT. PRESENT(index21) ) THEN ; iargidx = -1 879 ELSE ; iargidx = 21 ; iargval = index21 880 ENDIF 881 CASE ( 21 ) 882 IF( .NOT. PRESENT(index22) ) THEN ; iargidx = -1 883 ELSE ; iargidx = 22 ; iargval = index22 884 ENDIF 885 CASE ( 22 ) 886 IF( .NOT. PRESENT(index23) ) THEN ; iargidx = -1 887 ELSE ; iargidx = 23 ; iargval = index23 888 ENDIF 889 CASE ( 23 ) 890 IF( .NOT. PRESENT(index24) ) THEN ; iargidx = -1 891 ELSE ; iargidx = 24 ; iargval = index24 892 ENDIF 893 CASE ( 24 ) 894 IF( .NOT. PRESENT(index25) ) THEN ; iargidx = -1 895 ELSE ; iargidx = 25 ; iargval = index25 896 ENDIF 897 CASE ( 25 ) 898 IF( .NOT. PRESENT(index26) ) THEN ; iargidx = -1 899 ELSE ; iargidx = 26 ; iargval = index26 900 ENDIF 901 CASE ( 26 ) 902 IF( .NOT. PRESENT(index27) ) THEN ; iargidx = -1 903 ELSE ; iargidx = 27 ; iargval = index27 904 ENDIF 905 CASE ( 27 ) 906 iargidx = -1 907 CASE DEFAULT 908 ! BUG - iargidx shouldn't take any other values! 909 ! Flag error for calling routine 910 iargidx = -99 911 END SELECT 912 ! 913 END SUBROUTINE get_next_arg 914 915 !!===================================================================== 1194 916 END MODULE wrk_nemo
Note: See TracChangeset
for help on using the changeset viewer.