Changeset 3144 for branches/2011
- Timestamp:
- 2011-11-17T16:41:58+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/wrk_nemo_2.F90
r3134 r3144 17 17 !! INTEGER, POINTER, DIMENSION(:) :: arr1, arr2, ... arr10 18 18 !! ... 19 !! CALL wrk_alloc( nx, arr1, arr2, ... arr10 )20 !! ... 21 !! CALL wrk_dealloc( nx, arr1, arr2, ... arr10 19 !! CALL wrk_alloc( nx, arr1, arr2, ... arr10, kistart = kistart ) 20 !! ... 21 !! CALL wrk_dealloc( nx, arr1, arr2, ... arr10, kistart = kistart) 22 22 !! with: 23 23 !! - arr*: 1d arrays. real or (not and) integer 24 24 !! - nx: size of the 1d arr* arrays 25 25 !! - arr2, ..., arr10: optional parameters 26 !! - kistart: optional parameter to lower bound of the 1st dimension (default = 1) 26 27 !! 27 28 !! 2d arrays: … … 30 31 !! INTEGER, POINTER, DIMENSION(:,:) :: arr1, arr2, ... arr10 31 32 !! ... 32 !! CALL wrk_alloc( nx, ny, arr1, arr2, ... arr10 )33 !! ... 34 !! CALL wrk_dealloc( nx, ny, arr1, arr2, ... arr10 )33 !! CALL wrk_alloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart ) 34 !! ... 35 !! CALL wrk_dealloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart ) 35 36 !! with: 36 37 !! - arr* 2d arrays. real or (not and) integer 37 38 !! - nx, ny: size of the 2d arr* arrays 38 39 !! - arr2, ..., arr10: optional parameters 40 !! - kistart, kjstart: optional parameters to lower bound of the 1st/2nd dimension (default = 1) 39 41 !! 40 42 !! 3d arrays: … … 43 45 !! INTEGER, POINTER, DIMENSION(:,:,:) :: arr1, arr2, ... arr10 44 46 !! ... 45 !! CALL wrk_alloc( nx, ny, nz, arr1, arr2, ... arr10 )46 !! ... 47 !! CALL wrk_dealloc( nx, ny, nz, arr1, arr2, ... arr10 )47 !! CALL wrk_alloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart ) 48 !! ... 49 !! CALL wrk_dealloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart ) 48 50 !! with: 49 51 !! - arr* 3d arrays. real or (not and) integer 50 52 !! - nx, ny, nz: size of the 3d arr* arrays 51 53 !! - arr2, ..., arr10: optional parameters 54 !! - kistart, kjstart, kkstart: optional parameters to lower bound of the 1st/2nd/3rd dimension (default = 1) 52 55 !! 53 56 !! 4d arrays: … … 56 59 !! INTEGER, POINTER, DIMENSION(:,:,:,:) :: arr1, arr2, ... arr10 57 60 !! ... 58 !! CALL wrk_alloc( nx, ny, nz, nl, arr1, arr2, ... arr10 ) 59 !! ... 60 !! CALL wrk_dealloc( nx, ny, nz, nl, arr1, arr2, ... arr10 ) 61 !! CALL wrk_alloc( nx, ny, nz, nl, arr1, arr2, ... arr10, & 62 !! & kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart ) 63 !! ... 64 !! CALL wrk_dealloc( nx, ny, nz, nl, arr1, arr2, ... arr10, & 65 !! & kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart ) 61 66 !! with: 62 67 !! - arr* 3d arrays. real or (not and) integer 63 68 !! - nx, ny, nz, nl: size of the 4d arr* arrays 64 69 !! - arr2, ..., arr10: optional parameters 70 !! - kistart, kjstart, kkstart, klstart: optional parameters to lower bound of the 1st/2nd/3rd/4th dimension (default = 1) 65 71 !! 66 72 !!---------------------------------------------------------------------- … … 107 113 TYPE branch 108 114 INTEGER :: itype 109 INTEGER, DIMENSION(jpmaxdim) :: ishape 115 INTEGER, DIMENSION(jpmaxdim) :: ishape, istart 110 116 TYPE(leaf), POINTER :: start => NULL() 111 117 TYPE(leaf), POINTER :: current => NULL() … … 141 147 142 148 143 SUBROUTINE wrk_alloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10 )149 SUBROUTINE wrk_alloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart ) 144 150 INTEGER , INTENT(in ) :: kidim ! dimensions size 145 151 REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01 146 152 REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10 147 ! 148 CALL wrk_alloc_xd( kidim, 0, 0, 0, p1d01 = p1d01, p1d02 = p1d02, p1d03 = p1d03, p1d04 = p1d04, p1d05 = p1d05, & 149 & p1d06 = p1d06, p1d07 = p1d07, p1d08 = p1d08, p1d09 = p1d09, p1d10 = p1d10 ) 153 INTEGER , INTENT(in ), OPTIONAL :: kistart 154 ! 155 CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, & 156 & p1d01 = p1d01, p1d02 = p1d02, p1d03 = p1d03, p1d04 = p1d04, p1d05 = p1d05, & 157 & p1d06 = p1d06, p1d07 = p1d07, p1d08 = p1d08, p1d09 = p1d09, p1d10 = p1d10 ) 150 158 ! 151 159 END SUBROUTINE wrk_alloc_1dr 152 160 153 161 154 SUBROUTINE wrk_alloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10 )162 SUBROUTINE wrk_alloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart ) 155 163 INTEGER , INTENT(in ) :: kidim ! dimensions size 156 164 INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01 157 165 INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 158 ! 159 CALL wrk_alloc_xd( kidim, 0, 0, 0, k1d01 = k1d01, k1d02 = k1d02, k1d03 = k1d03, k1d04 = k1d04, k1d05 = k1d05, & 160 & k1d06 = k1d06, k1d07 = k1d07, k1d08 = k1d08, k1d09 = k1d09, k1d10 = k1d10 ) 166 INTEGER , INTENT(in ), OPTIONAL :: kistart 167 ! 168 CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, & 169 & k1d01 = k1d01, k1d02 = k1d02, k1d03 = k1d03, k1d04 = k1d04, k1d05 = k1d05, & 170 & k1d06 = k1d06, k1d07 = k1d07, k1d08 = k1d08, k1d09 = k1d09, k1d10 = k1d10 ) 161 171 ! 162 172 END SUBROUTINE wrk_alloc_1di 163 173 164 174 165 SUBROUTINE wrk_alloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10 )175 SUBROUTINE wrk_alloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart, kjstart ) 166 176 INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size 167 177 REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01 168 178 REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10 169 ! 170 CALL wrk_alloc_xd( kidim, kjdim, 0, 0, p2d01 = p2d01, p2d02 = p2d02, p2d03 = p2d03, p2d04 = p2d04, p2d05 = p2d05, & 171 & p2d06 = p2d06, p2d07 = p2d07, p2d08 = p2d08, p2d09 = p2d09, p2d10 = p2d10 ) 179 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart 180 ! 181 CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, & 182 & p2d01 = p2d01, p2d02 = p2d02, p2d03 = p2d03, p2d04 = p2d04, p2d05 = p2d05, & 183 & p2d06 = p2d06, p2d07 = p2d07, p2d08 = p2d08, p2d09 = p2d09, p2d10 = p2d10 ) 172 184 ! 173 185 END SUBROUTINE wrk_alloc_2dr 174 186 175 187 176 SUBROUTINE wrk_alloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10 )188 SUBROUTINE wrk_alloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart, kjstart ) 177 189 INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size 178 190 INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01 179 191 INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 180 ! 181 CALL wrk_alloc_xd( kidim, kjdim, 0, 0, k2d01 = k2d01, k2d02 = k2d02, k2d03 = k2d03, k2d04 = k2d04, k2d05 = k2d05, & 182 & k2d06 = k2d06, k2d07 = k2d07, k2d08 = k2d08, k2d09 = k2d09, k2d10 = k2d10 ) 192 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart 193 ! 194 CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, & 195 & k2d01 = k2d01, k2d02 = k2d02, k2d03 = k2d03, k2d04 = k2d04, k2d05 = k2d05, & 196 & k2d06 = k2d06, k2d07 = k2d07, k2d08 = k2d08, k2d09 = k2d09, k2d10 = k2d10 ) 183 197 ! 184 198 END SUBROUTINE wrk_alloc_2di 185 199 186 200 187 SUBROUTINE wrk_alloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10 ) 201 SUBROUTINE wrk_alloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, & 202 & kistart, kjstart, kkstart ) 188 203 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size 189 204 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01 190 205 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10 191 ! 192 CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, p3d01 = p3d01, p3d02 = p3d02, p3d03 = p3d03, p3d04 = p3d04, p3d05 = p3d05, & 193 & p3d06 = p3d06, p3d07 = p3d07, p3d08 = p3d08, p3d09 = p3d09, p3d10 = p3d10 ) 206 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart 207 ! 208 CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, & 209 & p3d01 = p3d01, p3d02 = p3d02, p3d03 = p3d03, p3d04 = p3d04, p3d05 = p3d05, & 210 & p3d06 = p3d06, p3d07 = p3d07, p3d08 = p3d08, p3d09 = p3d09, p3d10 = p3d10 ) 194 211 ! 195 212 END SUBROUTINE wrk_alloc_3dr 196 213 197 214 198 SUBROUTINE wrk_alloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10 ) 215 SUBROUTINE wrk_alloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, & 216 & kistart, kjstart, kkstart ) 199 217 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size 200 218 INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01 201 219 INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10 202 ! 203 CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, k3d01 = k3d01, k3d02 = k3d02, k3d03 = k3d03, k3d04 = k3d04, k3d05 = k3d05, & 204 & k3d06 = k3d06, k3d07 = k3d07, k3d08 = k3d08, k3d09 = k3d09, k3d10 = k3d10 ) 220 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart 221 ! 222 CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, & 223 & k3d01 = k3d01, k3d02 = k3d02, k3d03 = k3d03, k3d04 = k3d04, k3d05 = k3d05, & 224 & k3d06 = k3d06, k3d07 = k3d07, k3d08 = k3d08, k3d09 = k3d09, k3d10 = k3d10 ) 205 225 ! 206 226 END SUBROUTINE wrk_alloc_3di 207 227 208 228 209 SUBROUTINE wrk_alloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10 ) 229 SUBROUTINE wrk_alloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, & 230 & kistart, kjstart, kkstart, klstart ) 210 231 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size 211 232 REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01 212 233 REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10 213 ! 214 CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, p4d01 = p4d01, p4d02 = p4d02, p4d03 = p4d03, p4d04 = p4d04, p4d05 = p4d05, & 215 & p4d06 = p4d06, p4d07 = p4d07, p4d08 = p4d08, p4d09 = p4d09, p4d10 = p4d10 ) 234 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart 235 ! 236 CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, & 237 & p4d01 = p4d01, p4d02 = p4d02, p4d03 = p4d03, p4d04 = p4d04, p4d05 = p4d05, & 238 & p4d06 = p4d06, p4d07 = p4d07, p4d08 = p4d08, p4d09 = p4d09, p4d10 = p4d10 ) 216 239 ! 217 240 END SUBROUTINE wrk_alloc_4dr 218 241 219 242 220 SUBROUTINE wrk_alloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10 ) 243 SUBROUTINE wrk_alloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, & 244 & kistart, kjstart, kkstart, klstart ) 221 245 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size 222 246 INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01 223 247 INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10 224 ! 225 CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, k4d01 = k4d01, k4d02 = k4d02, k4d03 = k4d03, k4d04 = k4d04, k4d05 = k4d05, & 226 & k4d06 = k4d06, k4d07 = k4d07, k4d08 = k4d08, k4d09 = k4d09, k4d10 = k4d10 ) 248 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart 249 ! 250 CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, & 251 & k4d01 = k4d01, k4d02 = k4d02, k4d03 = k4d03, k4d04 = k4d04, k4d05 = k4d05, & 252 & k4d06 = k4d06, k4d07 = k4d07, k4d08 = k4d08, k4d09 = k4d09, k4d10 = k4d10 ) 227 253 ! 228 254 END SUBROUTINE wrk_alloc_4di 229 255 230 256 231 SUBROUTINE wrk_dealloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10 )257 SUBROUTINE wrk_dealloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart ) 232 258 INTEGER , INTENT(in ) :: kidim ! dimensions size 233 259 REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01 234 260 REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10 261 INTEGER , INTENT(in ), OPTIONAL :: kistart 235 262 ! 236 263 INTEGER :: icnt, jn 237 264 icnt = 1 + COUNT( (/ PRESENT(p1d02),PRESENT(p1d03),PRESENT(p1d04),PRESENT(p1d05), & 238 265 & PRESENT(p1d06),PRESENT(p1d07),PRESENT(p1d08),PRESENT(p1d09),PRESENT(p1d10) /) ) 239 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, 0, 0, 0 266 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, 0, 0, 0, kistart, 1, 1, 1) ; END DO 240 267 ! 241 268 END SUBROUTINE wrk_dealloc_1dr 242 269 243 270 244 SUBROUTINE wrk_dealloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10 )271 SUBROUTINE wrk_dealloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart ) 245 272 INTEGER , INTENT(in ) :: kidim ! dimensions size 246 273 INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01 247 274 INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 275 INTEGER , INTENT(in ), OPTIONAL :: kistart 248 276 ! 249 277 INTEGER :: icnt, jn 250 278 icnt = 1 + COUNT( (/ PRESENT(k1d02),PRESENT(k1d03),PRESENT(k1d04),PRESENT(k1d05), & 251 279 & PRESENT(k1d06),PRESENT(k1d07),PRESENT(k1d08),PRESENT(k1d09),PRESENT(k1d10) /) ) 252 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, 0, 0, 0 ) ; END DO280 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, 0, 0, 0, kistart, 1, 1, 1 ) ; END DO 253 281 ! 254 282 END SUBROUTINE wrk_dealloc_1di 255 283 256 284 257 SUBROUTINE wrk_dealloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10 )285 SUBROUTINE wrk_dealloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart,kjstart ) 258 286 INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size 259 287 REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01 260 288 REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10 289 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart 261 290 ! 262 291 INTEGER :: icnt, jn 263 292 icnt = 1 + COUNT( (/ PRESENT(p2d02),PRESENT(p2d03),PRESENT(p2d04),PRESENT(p2d05), & 264 293 & PRESENT(p2d06),PRESENT(p2d07),PRESENT(p2d08),PRESENT(p2d09),PRESENT(p2d10) /) ) 265 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, 0, 0 ) ; END DO294 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO 266 295 ! 267 296 END SUBROUTINE wrk_dealloc_2dr 268 297 269 298 270 SUBROUTINE wrk_dealloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10 )299 SUBROUTINE wrk_dealloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart,kjstart ) 271 300 INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size 272 301 INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01 273 302 INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 303 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart 274 304 ! 275 305 INTEGER :: icnt, jn 276 306 icnt = 1 + COUNT( (/ PRESENT(k2d02),PRESENT(k2d03),PRESENT(k2d04),PRESENT(k2d05), & 277 307 & PRESENT(k2d06),PRESENT(k2d07),PRESENT(k2d08),PRESENT(k2d09),PRESENT(k2d10) /) ) 278 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, 0, 0 ) ; END DO308 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO 279 309 ! 280 310 END SUBROUTINE wrk_dealloc_2di 281 311 282 312 283 SUBROUTINE wrk_dealloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10 ) 313 SUBROUTINE wrk_dealloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, & 314 & kistart, kjstart, kkstart ) 284 315 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size 285 316 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01 286 317 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10 318 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart 287 319 ! 288 320 INTEGER :: icnt, jn 289 321 icnt = 1 + COUNT( (/ PRESENT(p3d02),PRESENT(p3d03),PRESENT(p3d04),PRESENT(p3d05), & 290 322 & PRESENT(p3d06),PRESENT(p3d07),PRESENT(p3d08),PRESENT(p3d09),PRESENT(p3d10) /) ) 291 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, 0 ) ; END DO323 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO 292 324 ! 293 325 END SUBROUTINE wrk_dealloc_3dr 294 326 295 327 296 SUBROUTINE wrk_dealloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10 ) 328 SUBROUTINE wrk_dealloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, & 329 & kistart, kjstart, kkstart ) 297 330 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size 298 331 INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01 299 332 INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10 333 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart 300 334 ! 301 335 INTEGER :: icnt, jn 302 336 icnt = 1 + COUNT( (/ PRESENT(k3d02),PRESENT(k3d03),PRESENT(k3d04),PRESENT(k3d05), & 303 337 & PRESENT(k3d06),PRESENT(k3d07),PRESENT(k3d08),PRESENT(k3d09),PRESENT(k3d10) /) ) 304 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, 0 ) ; END DO338 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO 305 339 ! 306 340 END SUBROUTINE wrk_dealloc_3di 307 341 308 342 309 SUBROUTINE wrk_dealloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10 ) 343 SUBROUTINE wrk_dealloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, & 344 & kistart, kjstart, kkstart, klstart ) 310 345 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size 311 346 REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01 312 347 REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10 348 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart 313 349 ! 314 350 INTEGER :: icnt, jn 315 351 icnt = 1 + COUNT( (/ PRESENT(p4d02),PRESENT(p4d03),PRESENT(p4d04),PRESENT(p4d05), & 316 352 & PRESENT(p4d06),PRESENT(p4d07),PRESENT(p4d08),PRESENT(p4d09),PRESENT(p4d10) /) ) 317 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, kldim ) ;END DO353 DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO 318 354 ! 319 355 END SUBROUTINE wrk_dealloc_4dr 320 356 321 357 322 SUBROUTINE wrk_dealloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10 ) 358 SUBROUTINE wrk_dealloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, & 359 & kistart, kjstart, kkstart, klstart ) 323 360 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size 324 361 INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01 325 362 INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10 363 INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart 326 364 ! 327 365 INTEGER :: icnt, jn 328 366 icnt = 1 + COUNT( (/ PRESENT(k4d02),PRESENT(k4d03),PRESENT(k4d04),PRESENT(k4d05), & 329 367 & PRESENT(k4d06),PRESENT(k4d07),PRESENT(k4d08),PRESENT(k4d09),PRESENT(k4d10) /) ) 330 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, kldim ) ;END DO368 DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO 331 369 ! 332 370 END SUBROUTINE wrk_dealloc_4di … … 334 372 335 373 SUBROUTINE wrk_alloc_xd( kidim, kjdim, kkdim, kldim, & 374 & kisrt, kjsrt, kksrt, klsrt, & 336 375 & k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, & 337 376 & k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, & … … 343 382 & p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10 ) 344 383 INTEGER ,INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size 384 INTEGER ,INTENT(in ),OPTIONAL:: kisrt, kjsrt, kksrt, klsrt 345 385 INTEGER , POINTER, DIMENSION(: ),INTENT(inout),OPTIONAL:: k1d01,k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 346 386 INTEGER , POINTER, DIMENSION(:,: ),INTENT(inout),OPTIONAL:: k2d01,k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 … … 353 393 ! 354 394 LOGICAL :: llpres 355 INTEGER :: jn 395 INTEGER :: jn, iisrt, ijsrt, iksrt, ilsrt 356 396 ! 357 397 IF( .NOT. linit ) THEN 358 398 tree(:)%itype = jpnotdefined 359 DO jn = 1, jparray ; tree(jn)%ishape(:) = 0 ; END DO399 DO jn = 1, jparray ; tree(jn)%ishape(:) = 0 ; tree(jn)%istart(:) = 0 ; END DO 360 400 linit = .TRUE. 361 401 ENDIF 362 402 403 IF( PRESENT(kisrt) ) THEN ; iisrt = kisrt ; ELSE ; iisrt = 1 ; ENDIF 404 IF( PRESENT(kjsrt) ) THEN ; ijsrt = kjsrt ; ELSE ; ijsrt = 1 ; ENDIF 405 IF( PRESENT(kksrt) ) THEN ; iksrt = kksrt ; ELSE ; iksrt = 1 ; ENDIF 406 IF( PRESENT(klsrt) ) THEN ; ilsrt = klsrt ; ELSE ; ilsrt = 1 ; ENDIF 407 363 408 llpres = PRESENT(k1d01) .OR. PRESENT(k2d01) .OR. PRESENT(k3d01) .OR. PRESENT(k4d01) & 364 409 & .OR. PRESENT(p1d01) .OR. PRESENT(p2d01) .OR. PRESENT(p3d01) .OR. PRESENT(p4d01) 365 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d01, k2d01, k3d01, k4d01, p1d01, p2d01, p3d01, p4d01 ) 410 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 411 & k1d01, k2d01, k3d01, k4d01, p1d01, p2d01, p3d01, p4d01 ) 366 412 llpres = PRESENT(k1d02) .OR. PRESENT(k2d02) .OR. PRESENT(k3d02) .OR. PRESENT(k4d02) & 367 413 & .OR. PRESENT(p1d02) .OR. PRESENT(p2d02) .OR. PRESENT(p3d02) .OR. PRESENT(p4d02) 368 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d02, k2d02, k3d02, k4d02, p1d02, p2d02, p3d02, p4d02 ) 414 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 415 & k1d02, k2d02, k3d02, k4d02, p1d02, p2d02, p3d02, p4d02 ) 369 416 llpres = PRESENT(k1d03) .OR. PRESENT(k2d03) .OR. PRESENT(k3d03) .OR. PRESENT(k4d03) & 370 417 & .OR. PRESENT(p1d03) .OR. PRESENT(p2d03) .OR. PRESENT(p3d03) .OR. PRESENT(p4d03) 371 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d03, k2d03, k3d03, k4d03, p1d03, p2d03, p3d03, p4d03 ) 418 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 419 & k1d03, k2d03, k3d03, k4d03, p1d03, p2d03, p3d03, p4d03 ) 372 420 llpres = PRESENT(k1d04) .OR. PRESENT(k2d04) .OR. PRESENT(k3d04) .OR. PRESENT(k4d04) & 373 421 & .OR. PRESENT(p1d04) .OR. PRESENT(p2d04) .OR. PRESENT(p3d04) .OR. PRESENT(p4d04) 374 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d04, k2d04, k3d04, k4d04, p1d04, p2d04, p3d04, p4d04 ) 422 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 423 & k1d04, k2d04, k3d04, k4d04, p1d04, p2d04, p3d04, p4d04 ) 375 424 llpres = PRESENT(k1d05) .OR. PRESENT(k2d05) .OR. PRESENT(k3d05) .OR. PRESENT(k4d05) & 376 425 & .OR. PRESENT(p1d05) .OR. PRESENT(p2d05) .OR. PRESENT(p3d05) .OR. PRESENT(p4d05) 377 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d05, k2d05, k3d05, k4d05, p1d05, p2d05, p3d05, p4d05 ) 426 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 427 & k1d05, k2d05, k3d05, k4d05, p1d05, p2d05, p3d05, p4d05 ) 378 428 llpres = PRESENT(k1d06) .OR. PRESENT(k2d06) .OR. PRESENT(k3d06) .OR. PRESENT(k4d06) & 379 429 & .OR. PRESENT(p1d06) .OR. PRESENT(p2d06) .OR. PRESENT(p3d06) .OR. PRESENT(p4d06) 380 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d06, k2d06, k3d06, k4d06, p1d06, p2d06, p3d06, p4d06 ) 430 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 431 & k1d06, k2d06, k3d06, k4d06, p1d06, p2d06, p3d06, p4d06 ) 381 432 llpres = PRESENT(k1d07) .OR. PRESENT(k2d07) .OR. PRESENT(k3d07) .OR. PRESENT(k4d07) & 382 433 & .OR. PRESENT(p1d07) .OR. PRESENT(p2d07) .OR. PRESENT(p3d07) .OR. PRESENT(p4d07) 383 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d07, k2d07, k3d07, k4d07, p1d07, p2d07, p3d07, p4d07 ) 434 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 435 & k1d07, k2d07, k3d07, k4d07, p1d07, p2d07, p3d07, p4d07 ) 384 436 llpres = PRESENT(k1d08) .OR. PRESENT(k2d08) .OR. PRESENT(k3d08) .OR. PRESENT(k4d08) & 385 437 & .OR. PRESENT(p1d08) .OR. PRESENT(p2d08) .OR. PRESENT(p3d08) .OR. PRESENT(p4d08) 386 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d08, k2d08, k3d08, k4d08, p1d08, p2d08, p3d08, p4d08 ) 438 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 439 & k1d08, k2d08, k3d08, k4d08, p1d08, p2d08, p3d08, p4d08 ) 387 440 llpres = PRESENT(k1d09) .OR. PRESENT(k2d09) .OR. PRESENT(k3d09) .OR. PRESENT(k4d09) & 388 441 & .OR. PRESENT(p1d09) .OR. PRESENT(p2d09) .OR. PRESENT(p3d09) .OR. PRESENT(p4d09) 389 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d09, k2d09, k3d09, k4d09, p1d09, p2d09, p3d09, p4d09 ) 442 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 443 & k1d09, k2d09, k3d09, k4d09, p1d09, p2d09, p3d09, p4d09 ) 390 444 llpres = PRESENT(k1d10) .OR. PRESENT(k2d10) .OR. PRESENT(k3d10) .OR. PRESENT(k4d10) & 391 445 & .OR. PRESENT(p1d10) .OR. PRESENT(p2d10) .OR. PRESENT(p3d10) .OR. PRESENT(p4d10) 392 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, k1d10, k2d10, k3d10, k4d10, p1d10, p2d10, p3d10, p4d10 ) 446 IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & 447 & k1d10, k2d10, k3d10, k4d10, p1d10, p2d10, p3d10, p4d10 ) 393 448 394 449 END SUBROUTINE wrk_alloc_xd 395 450 396 451 397 SUBROUTINE wrk_allocbase( kidim, kjdim, kkdim, kldim, kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d ) 452 SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt , & 453 & kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d ) 398 454 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim 455 INTEGER , INTENT(in ) :: kisrt, kjsrt, kksrt, klsrt 399 456 INTEGER , POINTER, DIMENSION(:) , INTENT(inout), OPTIONAL :: kwrk1d 400 457 INTEGER , POINTER, DIMENSION(:,:) , INTENT(inout), OPTIONAL :: kwrk2d … … 406 463 REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: pwrk4d 407 464 ! 408 INTEGER, DIMENSION(jpmaxdim) :: ishape 465 INTEGER, DIMENSION(jpmaxdim) :: ishape, isrt, iend 409 466 INTEGER :: itype 410 467 INTEGER :: ii … … 412 469 ! define the shape to be given to the work array 413 470 ishape(:) = (/ kidim, kjdim, kkdim, kldim /) 471 ! define the starting index of the dimension shape to be given to the work array 472 isrt (:) = (/ kisrt, kjsrt, kksrt, klsrt /) 473 iend (:) = ishape(:) + isrt(:) - 1 414 474 415 475 ! is it integer or real array? … … 417 477 IF( PRESENT(pwrk1d) .OR. PRESENT(pwrk2d) .OR. PRESENT(pwrk3d) .OR. PRESENT(pwrk4d) ) itype = jpreal 418 478 419 ! find the branch with the matc ing shapeand type or get the first "free" branch479 ! find the branch with the matching shape, staring index and type or get the first "free" branch 420 480 ii = 1 421 DO WHILE( ( ANY( tree(ii)%ishape /= ishape ) .OR. tree(ii)%itype /= itype ) .AND. SUM( tree(ii)%ishape ) /= 0 ) 481 DO WHILE( ( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= isrt ) .OR. tree(ii)%itype /= itype ) & 482 & .AND. SUM( tree(ii)%ishape ) /= 0 ) 422 483 ii = ii + 1 423 484 IF (ii > jparray) STOP ! increase the value of jparray (should not be needed as already very big!) … … 426 487 IF( SUM( tree(ii)%ishape ) == 0 ) THEN ! create a new branch 427 488 tree(ii)%itype = itype ! define the type of this branch 428 tree(ii)%ishape(:) = ishape ! define the shape of this branch 489 tree(ii)%ishape(:) = ishape(:) ! define the shape of this branch 490 tree(ii)%istart(:) = isrt(:) ! define the lower bounds of this branch 429 491 ALLOCATE( tree(ii)%start ) ! allocate its start 430 492 ALLOCATE( tree(ii)%current) ! allocate the current leaf (the first leaf) … … 440 502 tree(ii)%current%next => NULL() ! next leaf is not yet defined 441 503 ! allocate the array of the first leaf 442 IF( present(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(kidim ) )443 IF( present(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(kidim,kjdim ) )444 IF( present(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(kidim,kjdim,kkdim ) )445 IF( present(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(kidim,kjdim,kkdim,kldim) )446 IF( present(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(kidim ) )447 IF( present(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(kidim,kjdim ) )448 IF( present(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(kidim,kjdim,kkdim ) )449 IF( present(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(kidim,kjdim,kkdim,kldim) )504 IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) ) 505 IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) 506 IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) 507 IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) 508 IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) ) 509 IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) 510 IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) 511 IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) 450 512 451 513 ELSE IF( .NOT. ASSOCIATED(tree(ii)%current%next) ) THEN ! all leafs used -> define a new one … … 459 521 460 522 ! allocate the array of the new leaf 461 IF( present(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(kidim ) )462 IF( present(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(kidim,kjdim ) )463 IF( present(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(kidim,kjdim,kkdim ) )464 IF( present(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(kidim,kjdim,kkdim,kldim) )465 IF( present(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(kidim ) )466 IF( present(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(kidim,kjdim ) )467 IF( present(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(kidim,kjdim,kkdim ) )468 IF( present(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(kidim,kjdim,kkdim,kldim) )523 IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) ) 524 IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) 525 IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) 526 IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) 527 IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) ) 528 IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) 529 IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) 530 IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) 469 531 470 532 ELSE … … 486 548 487 549 488 SUBROUTINE wrk_deallocbase( ktype, kidim, kjdim, kkdim, kldim ) 489 INTEGER, INTENT(in ) :: ktype 490 INTEGER, INTENT(in ) :: kidim, kjdim, kkdim, kldim 491 ! 550 SUBROUTINE wrk_deallocbase( ktype, kidim, kjdim, kkdim, kldim, kisrt, kjsrt, kksrt, klsrt ) 551 INTEGER, INTENT(in ) :: ktype 552 INTEGER, INTENT(in ) :: kidim, kjdim, kkdim, kldim 553 INTEGER, INTENT(in ), OPTIONAL :: kisrt, kjsrt, kksrt, klsrt 554 ! 555 INTEGER, DIMENSION(jpmaxdim) :: ishape, istart 492 556 INTEGER :: ii 557 558 ishape(:) = (/ kidim, kjdim, kkdim, kldim /) 559 IF( PRESENT(kisrt) ) THEN ; istart(1) = kisrt ; ELSE ; istart(1) = 1 ; ENDIF 560 IF( PRESENT(kjsrt) ) THEN ; istart(2) = kjsrt ; ELSE ; istart(2) = 1 ; ENDIF 561 IF( PRESENT(kksrt) ) THEN ; istart(3) = kksrt ; ELSE ; istart(3) = 1 ; ENDIF 562 IF( PRESENT(klsrt) ) THEN ; istart(4) = klsrt ; ELSE ; istart(4) = 1 ; ENDIF 493 563 494 564 ! find the branch with the matcing shape and type or get the first "free" branch 495 565 ii = 1 496 DO WHILE( ANY( tree(ii)%ishape /= (/ kidim, kjdim, kkdim, kldim /)) .OR. tree(ii)%itype /= ktype )566 DO WHILE( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= istart ) .OR. tree(ii)%itype /= ktype ) 497 567 ii = ii + 1 498 568 END DO
Note: See TracChangeset
for help on using the changeset viewer.