Changeset 14349
- Timestamp:
- 2021-01-27T14:57:31+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r14312_MPI_Interface
- Files:
-
- 11 edited
-
src/OCE/LBC/lbc_lnk_call_generic.h90 (modified) (7 diffs)
-
src/OCE/LBC/lbc_lnk_neicoll_generic.h90 (modified) (11 diffs)
-
src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 (modified) (12 diffs)
-
src/OCE/LBC/lbc_nfd_ext_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/lbc_nfd_generic.h90 (modified) (21 diffs)
-
src/OCE/LBC/lbc_nfd_nogather_generic.h90 (modified) (6 diffs)
-
src/OCE/LBC/lbclnk.F90 (modified) (4 diffs)
-
src/OCE/LBC/lbcnfd.F90 (modified) (7 diffs)
-
src/OCE/LBC/lib_mpp.F90 (modified) (1 diff)
-
src/OCE/LBC/mpp_nfd_generic.h90 (modified) (10 diffs)
-
tests/TSUNAMI/MY_SRC/usrdef_sbc.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_call_generic.h90
r14338 r14349 1 1 #if defined DIM_2d 2 # define XD 2d 3 # define DIMS1 :,: 4 # define DIMS2 :,:,1,1 2 # define XD 2d 3 # define DIMS :,: 4 # define ISZ3 1 5 # define ISZ4 1 5 6 #endif 6 7 #if defined DIM_3d 7 # define XD 3d 8 # define DIMS1 :,:,: 9 # define DIMS2 :,:,:,1 8 # define XD 3d 9 # define DIMS :,:,: 10 # define ISZ3 SIZE(ptab, dim=3) 11 # define ISZ4 1 10 12 #endif 11 13 #if defined DIM_4d 12 # define XD 4d 13 # define DIMS1 :,:,:,: 14 # define DIMS2 :,:,:,: 14 # define XD 4d 15 # define DIMS :,:,:,: 16 # define ISZ3 SIZE(ptab, dim=3) 17 # define ISZ4 SIZE(ptab, dim=4) 15 18 #endif 16 19 … … 24 27 !!--------------------------------------------------------------------- 25 28 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 26 REAL(PRECISION), DIMENSION(DIMS 1) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied27 REAL(PRECISION), DIMENSION(DIMS 1), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9, &29 REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 30 REAL(PRECISION), DIMENSION(DIMS), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9, & 28 31 & pt10, pt11, pt12, pt13, pt14, pt15, pt16 29 32 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points … … 39 42 !! 40 43 INTEGER :: kfld ! number of elements that will be attributed 41 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(16) :: ptab_ptr ! pointer array44 TYPE(PTR_4d_/**/PRECISION), DIMENSION(16) :: ptab_ptr ! pointer array 42 45 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 43 46 REAL(PRECISION) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary … … 65 68 IF( PRESENT(psgn15) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 66 69 IF( PRESENT(psgn16) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 67 ! 70 ! 68 71 IF( nn_comm == 1 ) THEN 69 72 CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) … … 77 80 SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 78 81 !!--------------------------------------------------------------------- 79 REAL(PRECISION), DIMENSION(DIMS 1), TARGET, INTENT(inout):: ptab ! arrays on which the lbc is applied82 REAL(PRECISION), DIMENSION(DIMS), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied 80 83 CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points 81 84 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 82 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers85 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers 83 86 CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points 84 87 REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary … … 87 90 ! 88 91 kfld = kfld + 1 89 ptab_ptr(kfld)%pt /**/XD=> ptab92 ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:ISZ3,1:ISZ4) => ptab 90 93 cdna_ptr(kfld) = cdna 91 94 psgn_ptr(kfld) = psgn … … 94 97 95 98 #undef XD 96 #undef DIMS1 97 #undef DIMS2 99 #undef DIMS 100 #undef ISZ3 101 #undef ISZ4 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
r14344 r14349 1 #if defined DIM_2d 2 # define XD 2d 3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 4 # define K_SIZE(ptab) 1 5 # define L_SIZE(ptab) 1 6 #endif 7 #if defined DIM_3d 8 # define XD 3d 9 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 10 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 11 # define L_SIZE(ptab) 1 12 #endif 13 #if defined DIM_4d 14 # define XD 4d 15 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 16 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 17 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 18 #endif 19 #define F_SIZE(ptab) kfld 20 21 SUBROUTINE lbc_lnk_neicoll_/**/XD/**/_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 1 2 SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 22 3 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 23 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.4 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 24 5 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 25 6 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary … … 52 33 LOGICAL :: ll_IdoNFold 53 34 !!---------------------------------------------------------------------- 54 #if defined PRINT_CAUTION55 !56 ! ================================================================================== !57 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !58 ! ================================================================================== !59 !60 #endif61 35 ! 62 36 ! ----------------------------------------- ! … … 64 38 ! ----------------------------------------- ! 65 39 ! 66 ipk = K_SIZE(ptab) ! 3rd dimension67 ipl = L_SIZE(ptab) ! 4th -68 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)40 ipk = SIZE(ptab(1)%pt4d,3) 41 ipl = SIZE(ptab(1)%pt4d,4) 42 ipf = kfld 69 43 ! 70 44 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) … … 162 136 ALLOCATE( zsnd(SUM(icounts)), zrcv(SUM(icountr)) ) 163 137 164 ! fill sending buffer with ARRAY_IN138 ! fill sending buffer with ptab(jf)%pt4d 165 139 idx = 1 166 140 DO jn = 1, 8 … … 169 143 ishtj = ishtsj(jn) 170 144 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 171 zsnd(idx) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf)145 zsnd(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) 172 146 idx = idx + 1 173 147 END DO ; END DO ; END DO ; END DO ; END DO … … 195 169 CASE ( jpfillmpi ) ! fill with data received by MPI 196 170 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 197 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idx)171 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idx) 198 172 idx = idx + 1 199 173 END DO ; END DO ; END DO ; END DO ; END DO … … 202 176 ishtj2 = ishtpj(jn) 203 177 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 204 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)178 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 205 179 END DO ; END DO ; END DO ; END DO ; END DO 206 180 CASE ( jpfillcopy ) ! filling with inner domain values … … 208 182 ishtj2 = ishtsj(jn) 209 183 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 210 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)184 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 211 185 END DO ; END DO ; END DO ; END DO ; END DO 212 186 CASE ( jpfillcst ) ! filling with constant value 213 187 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 214 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland188 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland 215 189 END DO ; END DO ; END DO ; END DO ; END DO 216 190 END SELECT … … 227 201 ishtj2 = ishtrj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done 228 202 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 229 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)203 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 230 204 END DO ; END DO ; END DO ; END DO ; END DO 231 205 ENDIF … … 236 210 ishtj2 = ishtpj(jn) ! use j- shift periodicity 237 211 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 238 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)212 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 239 213 END DO ; END DO ; END DO ; END DO ; END DO 240 214 ENDIF … … 251 225 ENDIF 252 226 ! 253 END SUBROUTINE lbc_lnk_neicoll_/**/XD/**/_/**/PRECISION 254 255 #undef XD 256 #undef ARRAY_IN 257 #undef K_SIZE 258 #undef L_SIZE 259 #undef F_SIZE 227 END SUBROUTINE lbc_lnk_neicoll_/**/PRECISION 228 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
r14343 r14349 1 #if defined DIM_2d2 # define XD 2d3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)4 # define K_SIZE(ptab) 15 # define L_SIZE(ptab) 16 #endif7 #if defined DIM_3d8 # define XD 3d9 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)10 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)11 # define L_SIZE(ptab) 112 #endif13 #if defined DIM_4d14 # define XD 4d15 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)16 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)17 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)18 #endif19 #define F_SIZE(ptab) kfld20 1 21 SUBROUTINE lbc_lnk_pt2pt_/**/ XD/**/_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )2 SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 22 3 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 23 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.4 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 24 5 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 25 6 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary … … 45 26 LOGICAL :: ll_IdoNFold 46 27 !!---------------------------------------------------------------------- 47 #if defined PRINT_CAUTION48 !49 ! ================================================================================== !50 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !51 ! ================================================================================== !52 !53 #endif54 28 ! 55 29 ! ----------------------------------------- ! … … 57 31 ! ----------------------------------------- ! 58 32 ! 59 ipk = K_SIZE(ptab) ! 3rd dimension60 ipl = L_SIZE(ptab) ! 4th -61 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 ipk = SIZE(ptab(1)%pt4d,3) 34 ipl = SIZE(ptab(1)%pt4d,4) 35 ipf = kfld 62 36 ! 63 37 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) … … 148 122 ishtj = ishtsj(jn) 149 123 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 150 zsnd(idxs) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf)124 zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) 151 125 idxs = idxs + 1 152 126 END DO ; END DO ; END DO ; END DO ; END DO … … 184 158 CASE ( jpfillmpi ) ! fill with data received by MPI 185 159 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 186 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idxr)160 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr) 187 161 idxr = idxr + 1 188 162 END DO ; END DO ; END DO ; END DO ; END DO … … 191 165 ishtj2 = ishtpj(jn) 192 166 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 193 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)167 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 194 168 END DO ; END DO ; END DO ; END DO ; END DO 195 169 CASE ( jpfillcopy ) ! filling with inner domain values … … 197 171 ishtj2 = ishtsj(jn) 198 172 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 199 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)173 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 200 174 END DO ; END DO ; END DO ; END DO ; END DO 201 175 CASE ( jpfillcst ) ! filling with constant value 202 176 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 203 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland177 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland 204 178 END DO ; END DO ; END DO ; END DO ; END DO 205 179 END SELECT … … 227 201 ishtj = ishtsj(jn) 228 202 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 229 zsnd(idxs) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf)203 zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) 230 204 idxs = idxs + 1 231 205 END DO ; END DO ; END DO ; END DO ; END DO … … 261 235 CASE ( jpfillmpi ) ! fill with data received by MPI 262 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 263 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idxr)237 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr) 264 238 idxr = idxr + 1 265 239 END DO ; END DO ; END DO ; END DO ; END DO … … 268 242 ishtj2 = ishtpj(jn) 269 243 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 270 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)244 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 271 245 END DO ; END DO ; END DO ; END DO ; END DO 272 246 CASE ( jpfillcopy ) ! filling with inner domain values … … 274 248 ishtj2 = ishtsj(jn) 275 249 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 276 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf)250 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 277 251 END DO ; END DO ; END DO ; END DO ; END DO 278 252 CASE ( jpfillcst ) ! filling with constant value 279 253 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 280 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland254 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland 281 255 END DO ; END DO ; END DO ; END DO ; END DO 282 256 END SELECT … … 290 264 DEALLOCATE( zsnd, zrcv ) 291 265 ! 292 END SUBROUTINE lbc_lnk_pt2pt_/**/ XD/**/_/**/PRECISION266 END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION 293 267 294 #undef XD295 #undef ARRAY_IN296 #undef K_SIZE297 #undef L_SIZE298 #undef F_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_ext_generic.h90
r14338 r14349 1 #if defined DIM_2d2 # define XD 2d3 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)4 # define K_SIZE(ptab) 15 # define L_SIZE(ptab) 16 #else7 === NOT CODED ===8 #endif9 #define F_SIZE(ptab) 110 1 11 SUBROUTINE lbc_nfd_ext_/**/ XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kextj )2 SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 12 3 !!---------------------------------------------------------------------- 13 4 REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab … … 15 6 REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary 16 7 INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold 17 !! INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ptab18 8 ! 19 INTEGER :: ji, jj, j k, jl, jh, jf! dummy loop indices20 INTEGER :: ip i, ipj, ipk, ipl, ipf ! dimension of the input array9 INTEGER :: ji, jj, jh ! dummy loop indices 10 INTEGER :: ipj 21 11 INTEGER :: ijt, iju, ipjm1 22 12 !!---------------------------------------------------------------------- 23 !24 ipk = K_SIZE(ptab) ! 3rd dimension25 ipl = L_SIZE(ptab) ! 4th -26 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)27 13 ! 28 14 SELECT CASE ( jpni ) … … 32 18 ! 33 19 ipjm1 = ipj-1 20 ! 21 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 22 ! 23 SELECT CASE ( cd_nat ) 24 CASE ( 'T' , 'W' ) ! T-, W-point 25 DO jh = 0, kextj 26 DO ji = 2, jpiglo 27 ijt = jpiglo-ji+2 28 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 29 END DO 30 ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) 31 END DO 32 DO ji = jpiglo/2+1, jpiglo 33 ijt = jpiglo-ji+2 34 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 35 END DO 36 CASE ( 'U' ) ! U-point 37 DO jh = 0, kextj 38 DO ji = 2, jpiglo-1 39 iju = jpiglo-ji+1 40 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) 41 END DO 42 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) 43 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) 44 END DO 45 DO ji = jpiglo/2, jpiglo-1 46 iju = jpiglo-ji+1 47 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 48 END DO 49 CASE ( 'V' ) ! V-point 50 DO jh = 0, kextj 51 DO ji = 2, jpiglo 52 ijt = jpiglo-ji+2 53 ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) 54 ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) 55 END DO 56 ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) 57 END DO 58 CASE ( 'F' ) ! F-point 59 DO jh = 0, kextj 60 DO ji = 1, jpiglo-1 61 iju = jpiglo-ji+1 62 ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) 63 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) 64 END DO 65 END DO 66 DO jh = 0, kextj 67 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) 68 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) 69 END DO 70 END SELECT 71 ! 72 ENDIF ! c_NFtype == 'T' 73 ! 74 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 75 ! 76 SELECT CASE ( cd_nat ) 77 CASE ( 'T' , 'W' ) ! T-, W-point 78 DO jh = 0, kextj 79 DO ji = 1, jpiglo 80 ijt = jpiglo-ji+1 81 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) 82 END DO 83 END DO 84 CASE ( 'U' ) ! U-point 85 DO jh = 0, kextj 86 DO ji = 1, jpiglo-1 87 iju = jpiglo-ji 88 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) 89 END DO 90 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) 91 END DO 92 CASE ( 'V' ) ! V-point 93 DO jh = 0, kextj 94 DO ji = 1, jpiglo 95 ijt = jpiglo-ji+1 96 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 97 END DO 98 END DO 99 DO ji = jpiglo/2+1, jpiglo 100 ijt = jpiglo-ji+1 101 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 102 END DO 103 CASE ( 'F' ) ! F-point 104 DO jh = 0, kextj 105 DO ji = 1, jpiglo-1 106 iju = jpiglo-ji 107 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) 108 END DO 109 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) 110 END DO 111 DO ji = jpiglo/2+1, jpiglo-1 112 iju = jpiglo-ji 113 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 114 END DO 115 END SELECT 116 ! 117 ENDIF ! c_NFtype == 'F' 118 ! 119 END SUBROUTINE lbc_nfd_ext_/**/PRECISION 34 120 35 !36 DO jf = 1, ipf ! Loop on the number of arrays to be treated37 !38 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot39 !40 SELECT CASE ( cd_nat )41 CASE ( 'T' , 'W' ) ! T-, W-point42 DO jh = 0, kextj43 DO ji = 2, jpiglo44 ijt = jpiglo-ji+245 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)46 END DO47 ARRAY_IN(1,ipj+jh,:,:,jf) = psgn * ARRAY_IN(3,ipj-2-jh,:,:,jf)48 END DO49 DO ji = jpiglo/2+1, jpiglo50 ijt = jpiglo-ji+251 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(ijt,ipjm1,:,:,jf)52 END DO53 CASE ( 'U' ) ! U-point54 DO jh = 0, kextj55 DO ji = 2, jpiglo-156 iju = jpiglo-ji+157 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf)58 END DO59 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = psgn * ARRAY_IN( 2 ,ipj-2-jh,:,:,jf)60 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf)61 END DO62 DO ji = jpiglo/2, jpiglo-163 iju = jpiglo-ji+164 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(iju,ipjm1,:,:,jf)65 END DO66 CASE ( 'V' ) ! V-point67 DO jh = 0, kextj68 DO ji = 2, jpiglo69 ijt = jpiglo-ji+270 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)71 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-3-jh,:,:,jf)72 END DO73 ARRAY_IN(1,ipj+jh,:,:,jf) = psgn * ARRAY_IN(3,ipj-3-jh,:,:,jf)74 END DO75 CASE ( 'F' ) ! F-point76 DO jh = 0, kextj77 DO ji = 1, jpiglo-178 iju = jpiglo-ji+179 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf)80 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(iju,ipj-3-jh,:,:,jf)81 END DO82 END DO83 DO jh = 0, kextj84 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = psgn * ARRAY_IN( 2 ,ipj-3-jh,:,:,jf)85 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf)86 END DO87 END SELECT88 !89 ENDIF ! c_NFtype == 'T'90 !91 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot92 !93 SELECT CASE ( cd_nat )94 CASE ( 'T' , 'W' ) ! T-, W-point95 DO jh = 0, kextj96 DO ji = 1, jpiglo97 ijt = jpiglo-ji+198 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-1-jh,:,:,jf)99 END DO100 END DO101 CASE ( 'U' ) ! U-point102 DO jh = 0, kextj103 DO ji = 1, jpiglo-1104 iju = jpiglo-ji105 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-1-jh,:,:,jf)106 END DO107 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf)108 END DO109 CASE ( 'V' ) ! V-point110 DO jh = 0, kextj111 DO ji = 1, jpiglo112 ijt = jpiglo-ji+1113 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)114 END DO115 END DO116 DO ji = jpiglo/2+1, jpiglo117 ijt = jpiglo-ji+1118 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(ijt,ipjm1,:,:,jf)119 END DO120 CASE ( 'F' ) ! F-point121 DO jh = 0, kextj122 DO ji = 1, jpiglo-1123 iju = jpiglo-ji124 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf)125 END DO126 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf)127 END DO128 DO ji = jpiglo/2+1, jpiglo-1129 iju = jpiglo-ji130 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(iju,ipjm1,:,:,jf)131 END DO132 END SELECT133 !134 ENDIF ! c_NFtype == 'F'135 !136 END DO137 !138 END SUBROUTINE lbc_nfd_ext_/**/XD/**/_/**/PRECISION139 140 #undef XD141 #undef ARRAY_IN142 #undef K_SIZE143 #undef L_SIZE144 #undef F_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_generic.h90
r14338 r14349 1 #if defined DIM_2d2 # define XD 2d3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)4 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2)5 # define K_SIZE(ptab) 16 # define L_SIZE(ptab) 17 #endif8 #if defined DIM_3d9 # define XD 3d10 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)11 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2)12 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)13 # define L_SIZE(ptab) 114 #endif15 #if defined DIM_4d16 # define XD 4d17 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)18 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2)19 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)20 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)21 #endif22 #define F_SIZE(ptab) kfld23 1 24 SUBROUTINE lbc_nfd_/**/ XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kfld )25 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.2 SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfld ) 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 26 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 27 5 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary … … 33 11 !!---------------------------------------------------------------------- 34 12 ! 35 ipj = J_SIZE(ptab) ! 2nd dimension36 ipk = K_SIZE(ptab) ! 3rd -37 ipl = L_SIZE(ptab) ! 4th -38 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)13 ipj = SIZE(ptab(1)%pt4d,2) 14 ipk = SIZE(ptab(1)%pt4d,3) 15 ipl = SIZE(ptab(1)%pt4d,4) 16 ipf = kfld 39 17 ! 40 18 DO jf = 1, ipf ! Loop on the number of arrays to be treated … … 54 32 ii1 = ji ! ends at: nn_hls 55 33 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 56 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)34 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 57 35 END DO 58 36 DO ji = 1, 1 ! point nn_hls+1 59 37 ii1 = nn_hls + ji 60 38 ii2 = ii1 61 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)39 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 62 40 END DO 63 41 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 64 42 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 65 43 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 66 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)44 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 67 45 END DO 68 46 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 69 47 ii1 = jpiglo - nn_hls + ji 70 48 ii2 = nn_hls + ji 71 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)49 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 72 50 END DO 73 51 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 74 52 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 75 53 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 76 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)54 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 77 55 END DO 78 56 END DO … … 86 64 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 87 65 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 88 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)66 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 89 67 END DO 90 68 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 92 70 ii1 = ji ! ends at: nn_hls 93 71 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 94 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)72 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 95 73 END DO 96 74 ! ! last nn_hls-1 points: have been / will done by e-w periodicity … … 109 87 ii1 = ji ! ends at: nn_hls 110 88 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 111 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)89 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 112 90 END DO 113 91 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 114 92 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 115 93 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 116 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)94 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 117 95 END DO 118 96 DO ji = 1, nn_hls ! last nn_hls points 119 97 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 120 98 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 121 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)99 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 122 100 END DO 123 101 END DO … … 131 109 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 132 110 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 133 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)111 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 134 112 END DO 135 113 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 137 115 ii1 = ji ! ends at: nn_hls 138 116 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 139 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)117 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 140 118 END DO 141 119 ! ! last nn_hls-1 points: have been / will done by e-w periodicity … … 154 132 ii1 = ji ! ends at: nn_hls 155 133 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 156 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)134 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 157 135 END DO 158 136 DO ji = 1, 1 ! point nn_hls+1 159 137 ii1 = nn_hls + ji 160 138 ii2 = ii1 161 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)139 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 162 140 END DO 163 141 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 164 142 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 165 143 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 166 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)144 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 167 145 END DO 168 146 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 169 147 ii1 = jpiglo - nn_hls + ji 170 148 ii2 = nn_hls + ji 171 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)149 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 172 150 END DO 173 151 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 174 152 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 175 153 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 176 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)154 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 177 155 END DO 178 156 END DO … … 190 168 ii1 = ji ! ends at: nn_hls 191 169 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 192 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)170 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 193 171 END DO 194 172 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 195 173 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 196 174 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 197 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)175 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 198 176 END DO 199 177 DO ji = 1, nn_hls ! last nn_hls points 200 178 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 201 179 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 202 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)180 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 203 181 END DO 204 182 END DO … … 223 201 ii1 = jpiglo/2 + ji 224 202 ii2 = jpiglo/2 - ji + 1 225 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...203 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 226 204 END DO 227 205 DO ji = 1, 1 ! points jpiglo - nn_hls 228 206 ii1 = jpiglo - nn_hls + ji - 1 229 207 ii2 = nn_hls + ji 230 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...208 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 231 209 END DO 232 210 DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done) … … 234 212 ii1 = nn_hls + ji - 1 235 213 ii2 = nn_hls + ji 236 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...214 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 237 215 END DO 238 216 END DO … … 246 224 ii1 = ji ! ends at: nn_hls 247 225 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 248 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)226 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 249 227 END DO 250 228 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 251 229 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 252 230 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 253 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)231 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 254 232 END DO 255 233 DO ji = 1, nn_hls ! last nn_hls points 256 234 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 257 235 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 258 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)236 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 259 237 END DO 260 238 END DO … … 272 250 ii1 = ji ! ends at: nn_hls-1 273 251 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 274 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)252 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 275 253 END DO 276 254 DO ji = 1, 1 ! point nn_hls 277 255 ii1 = nn_hls + ji - 1 278 256 ii2 = jpiglo - ii1 279 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)257 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 280 258 END DO 281 259 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 282 260 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 283 261 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 284 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)262 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 285 263 END DO 286 264 DO ji = 1, 1 ! point jpiglo - nn_hls 287 265 ii1 = jpiglo - nn_hls + ji - 1 288 266 ii2 = ii1 289 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)267 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 290 268 END DO 291 269 DO ji = 1, nn_hls ! last nn_hls points 292 270 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 293 271 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 294 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)272 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 295 273 END DO 296 274 END DO … … 308 286 ii1 = ji ! ends at: nn_hls 309 287 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 310 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)288 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 311 289 END DO 312 290 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 313 291 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 314 292 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 315 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)293 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 316 294 END DO 317 295 DO ji = 1, nn_hls ! last nn_hls points 318 296 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 319 297 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 320 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)298 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 321 299 END DO 322 300 END DO … … 330 308 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 331 309 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 332 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)310 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 333 311 END DO 334 312 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 336 314 ii1 = ji ! ends at: nn_hls 337 315 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 338 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)316 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 339 317 END DO 340 318 ! ! last nn_hls points: have been / will done by e-w periodicity … … 353 331 ii1 = ji ! ends at: nn_hls-1 354 332 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 355 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)333 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 356 334 END DO 357 335 DO ji = 1, 1 ! point nn_hls 358 336 ii1 = nn_hls + ji - 1 359 337 ii2 = jpiglo - ii1 360 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)338 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 361 339 END DO 362 340 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 363 341 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 364 342 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 365 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)343 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 366 344 END DO 367 345 DO ji = 1, 1 ! point jpiglo - nn_hls 368 346 ii1 = jpiglo - nn_hls + ji - 1 369 347 ii2 = ii1 370 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)348 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 371 349 END DO 372 350 DO ji = 1, nn_hls ! last nn_hls points 373 351 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 374 352 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 375 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)353 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 376 354 END DO 377 355 END DO … … 385 363 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 386 364 ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 387 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)365 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 388 366 END DO 389 367 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) … … 391 369 ii1 = ji ! ends at: nn_hls 392 370 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 393 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)371 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 394 372 END DO 395 373 ! ! last nn_hls points: have been / will done by e-w periodicity … … 403 381 END DO ! ipf 404 382 ! 405 END SUBROUTINE lbc_nfd_/**/ XD/**/_/**/PRECISION383 END SUBROUTINE lbc_nfd_/**/PRECISION 406 384 407 #undef XD408 #undef ARRAY_IN409 #undef J_SIZE410 #undef K_SIZE411 #undef L_SIZE412 #undef F_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r14343 r14349 1 #if defined DIM_2d2 # define XD 2d3 # define DIMS_IN :,:4 # define ARRAY_IN(i,j,k,l) ptab(i,j)5 # define K_SIZE(ptab) 16 # define L_SIZE(ptab) 17 #endif8 #if defined DIM_3d9 # define XD 3d10 # define DIMS_IN :,:,:11 # define ARRAY_IN(i,j,k,l) ptab(i,j,k)12 # define K_SIZE(ptab) SIZE(ptab,3)13 # define L_SIZE(ptab) 114 #endif15 #if defined DIM_4d16 # define XD 4d17 # define DIMS_IN :,:,:,:18 # define ARRAY_IN(i,j,k,l) ptab(i,j,k,l)19 # define K_SIZE(ptab) SIZE(ptab,3)20 # define L_SIZE(ptab) SIZE(ptab,4)21 #endif22 1 23 SUBROUTINE lbc_nfd_nogather_/**/ XD/**/_/**/PRECISION( ptab, ptab2, cd_nat, psgn )2 SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn ) 24 3 !!---------------------------------------------------------------------- 25 4 !! … … 28 7 !! 29 8 !!---------------------------------------------------------------------- 30 REAL(PRECISION), DIMENSION( DIMS_IN), INTENT(inout) :: ptab!31 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab2!32 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of array grid-points33 REAL(PRECISION) ,INTENT(in ) :: psgn ! sign used across the north fold boundary9 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab ! 10 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab2 ! 11 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of array grid-points 12 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 34 13 ! 35 14 INTEGER :: ji, jj, jk, jn, jl, jh ! dummy loop indices … … 38 17 LOGICAL :: l_fast_exchanges 39 18 !!---------------------------------------------------------------------- 40 ipk = K_SIZE(ptab) ! 3rd dimension of output array41 ipl = L_SIZE(ptab) ! 4th -19 ipk = SIZE(ptab,3) 20 ipl = SIZE(ptab,4) 42 21 ! 43 22 ! 2nd dimension determines exchange speed 44 23 l_fast_exchanges = SIZE(ptab2,2) == 1 24 ! 25 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 45 26 ! 46 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 47 ! 48 SELECT CASE ( cd_nat ) 49 ! 50 CASE ( 'T' , 'W' ) ! T-, W-point 51 IF ( nimpp /= 1 ) THEN ; startloop = 1 52 ELSE ; startloop = 1 + nn_hls 53 ENDIF 54 ! 55 DO jl = 1, ipl; DO jk = 1, ipk 56 DO jj = 1, nn_hls 57 ijj = jpj -jj +1 27 SELECT CASE ( cd_nat ) 28 ! 29 CASE ( 'T' , 'W' ) ! T-, W-point 30 IF ( nimpp /= 1 ) THEN ; startloop = 1 31 ELSE ; startloop = 1 + nn_hls 32 ENDIF 33 ! 34 DO jl = 1, ipl; DO jk = 1, ipk 35 DO jj = 1, nn_hls 36 ijj = jpj -jj +1 37 DO ji = startloop, jpi 38 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 39 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 40 END DO 41 END DO 42 END DO; END DO 43 IF( nimpp == 1 ) THEN 44 DO jl = 1, ipl; DO jk = 1, ipk 45 DO jj = 1, nn_hls 46 ijj = jpj -jj +1 47 DO ii = 0, nn_hls-1 48 ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl) 49 END DO 50 END DO 51 END DO; END DO 52 ENDIF 53 ! 54 IF ( .NOT. l_fast_exchanges ) THEN 55 IF( nimpp >= Ni0glo/2+2 ) THEN 56 startloop = 1 57 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 58 startloop = Ni0glo/2+2 - nimpp + nn_hls 59 ELSE 60 startloop = jpi + 1 61 ENDIF 62 IF( startloop <= jpi ) THEN 63 DO jl = 1, ipl; DO jk = 1, ipk 58 64 DO ji = startloop, jpi 59 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 60 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 61 END DO 62 END DO 63 END DO; END DO 64 IF( nimpp == 1 ) THEN 65 DO jl = 1, ipl; DO jk = 1, ipk 66 DO jj = 1, nn_hls 67 ijj = jpj -jj +1 68 DO ii = 0, nn_hls-1 69 ARRAY_IN(ii+1,ijj,jk,jl) = psgn * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl) 70 END DO 65 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 66 jia = ji + nimpp - 1 67 ijta = jpiglo - jia + 2 68 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 69 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl) 70 ELSE 71 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl) 72 ENDIF 71 73 END DO 72 74 END DO; END DO 73 ENDIF 74 ! 75 IF ( .NOT. l_fast_exchanges ) THEN 76 IF( nimpp >= Ni0glo/2+2 ) THEN 77 startloop = 1 78 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 79 startloop = Ni0glo/2+2 - nimpp + nn_hls 80 ELSE 81 startloop = jpi + 1 82 ENDIF 83 IF( startloop <= jpi ) THEN 84 DO jl = 1, ipl; DO jk = 1, ipk 85 DO ji = startloop, jpi 86 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 87 jia = ji + nimpp - 1 88 ijta = jpiglo - jia + 2 89 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 90 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl) 91 ELSE 92 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl) 93 ENDIF 94 END DO 95 END DO; END DO 96 ENDIF 97 ENDIF 98 CASE ( 'U' ) ! U-point 75 ENDIF 76 ENDIF 77 CASE ( 'U' ) ! U-point 78 IF( nimpp + jpi - 1 /= jpiglo ) THEN 79 endloop = jpi 80 ELSE 81 endloop = jpi - nn_hls 82 ENDIF 83 DO jl = 1, ipl; DO jk = 1, ipk 84 DO jj = 1, nn_hls 85 ijj = jpj -jj +1 86 DO ji = 1, endloop 87 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 88 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 89 END DO 90 END DO 91 END DO; END DO 92 IF (nimpp .eq. 1) THEN 93 DO jj = 1, nn_hls 94 ijj = jpj -jj +1 95 DO ii = 0, nn_hls-1 96 ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 97 END DO 98 END DO 99 ENDIF 100 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 101 DO jj = 1, nn_hls 102 ijj = jpj -jj +1 103 DO ii = 1, nn_hls 104 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 105 END DO 106 END DO 107 ENDIF 108 ! 109 IF ( .NOT. l_fast_exchanges ) THEN 99 110 IF( nimpp + jpi - 1 /= jpiglo ) THEN 100 111 endloop = jpi … … 102 113 endloop = jpi - nn_hls 103 114 ENDIF 104 DO jl = 1, ipl; DO jk = 1, ipk 105 DO jj = 1, nn_hls 106 ijj = jpj -jj +1 107 DO ji = 1, endloop 108 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 109 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 110 END DO 111 END DO 112 END DO; END DO 113 IF (nimpp .eq. 1) THEN 114 DO jj = 1, nn_hls 115 ijj = jpj -jj +1 116 DO ii = 0, nn_hls-1 117 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 118 END DO 119 END DO 120 ENDIF 121 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 122 DO jj = 1, nn_hls 123 ijj = jpj -jj +1 124 DO ii = 1, nn_hls 125 ARRAY_IN(jpi-ii+1,ijj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 126 END DO 127 END DO 128 ENDIF 129 ! 130 IF ( .NOT. l_fast_exchanges ) THEN 131 IF( nimpp + jpi - 1 /= jpiglo ) THEN 132 endloop = jpi 133 ELSE 134 endloop = jpi - nn_hls 135 ENDIF 136 IF( nimpp >= Ni0glo/2+1 ) THEN 137 startloop = nn_hls 138 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 139 startloop = Ni0glo/2+1 - nimpp + nn_hls 140 ELSE 141 startloop = endloop + 1 142 ENDIF 143 IF( startloop <= endloop ) THEN 115 IF( nimpp >= Ni0glo/2+1 ) THEN 116 startloop = nn_hls 117 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 118 startloop = Ni0glo/2+1 - nimpp + nn_hls 119 ELSE 120 startloop = endloop + 1 121 ENDIF 122 IF( startloop <= endloop ) THEN 144 123 DO jl = 1, ipl; DO jk = 1, ipk 145 124 DO ji = startloop, endloop … … 148 127 ijua = jpiglo - jia + 1 149 128 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 150 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl)129 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-nn_hls,jk,jl) 151 130 ELSE 152 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl)131 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl) 153 132 ENDIF 154 133 END DO 155 134 END DO; END DO 156 ENDIF 157 ENDIF 158 ! 159 CASE ( 'V' ) ! V-point 160 IF( nimpp /= 1 ) THEN 161 startloop = 1 162 ELSE 163 startloop = 1 + nn_hls 164 ENDIF 135 ENDIF 136 ENDIF 137 ! 138 CASE ( 'V' ) ! V-point 139 IF( nimpp /= 1 ) THEN 140 startloop = 1 141 ELSE 142 startloop = 1 + nn_hls 143 ENDIF 144 IF ( .NOT. l_fast_exchanges ) THEN 145 DO jl = 1, ipl; DO jk = 1, ipk 146 DO jj = 2, nn_hls+1 147 ijj = jpj -jj +1 148 DO ji = startloop, jpi 149 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 150 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 151 END DO 152 END DO 153 END DO; END DO 154 ENDIF 155 DO jl = 1, ipl; DO jk = 1, ipk 156 DO ji = startloop, jpi 157 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 158 ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 159 END DO 160 END DO; END DO 161 IF (nimpp .eq. 1) THEN 162 DO jj = 1, nn_hls 163 ijj = jpj-jj+1 164 DO ii = 0, nn_hls-1 165 ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:) 166 END DO 167 END DO 168 ENDIF 169 CASE ( 'F' ) ! F-point 170 IF( nimpp + jpi - 1 /= jpiglo ) THEN 171 endloop = jpi 172 ELSE 173 endloop = jpi - nn_hls 174 ENDIF 175 IF ( .NOT. l_fast_exchanges ) THEN 176 DO jl = 1, ipl; DO jk = 1, ipk 177 DO jj = 2, nn_hls+1 178 ijj = jpj -jj +1 179 DO ji = 1, endloop 180 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 181 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 182 END DO 183 END DO 184 END DO; END DO 185 ENDIF 186 DO jl = 1, ipl; DO jk = 1, ipk 187 DO ji = 1, endloop 188 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 189 ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 190 END DO 191 END DO; END DO 192 IF (nimpp .eq. 1) THEN 193 DO ii = 1, nn_hls 194 ptab(ii,jpj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls-1,:,:) 195 END DO 165 196 IF ( .NOT. l_fast_exchanges ) THEN 197 DO jj = 1, nn_hls 198 ijj = jpj -jj 199 DO ii = 0, nn_hls-1 200 ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 201 END DO 202 END DO 203 ENDIF 204 ENDIF 205 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 206 DO ii = 1, nn_hls 207 ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:) 208 END DO 209 IF ( .NOT. l_fast_exchanges ) THEN 210 DO jj = 1, nn_hls 211 ijj = jpj -jj 212 DO ii = 1, nn_hls 213 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 214 END DO 215 END DO 216 ENDIF 217 ENDIF 218 ! 219 END SELECT 220 ! 221 ENDIF ! c_NFtype == 'T' 222 ! 223 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 224 ! 225 SELECT CASE ( cd_nat ) 226 CASE ( 'T' , 'W' ) ! T-, W-point 227 DO jl = 1, ipl; DO jk = 1, ipk 228 DO jj = 1, nn_hls 229 ijj = jpj-jj+1 230 DO ji = 1, jpi 231 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 232 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 233 END DO 234 END DO 235 END DO; END DO 236 ! 237 CASE ( 'U' ) ! U-point 238 IF( nimpp + jpi - 1 /= jpiglo ) THEN 239 endloop = jpi 240 ELSE 241 endloop = jpi - nn_hls 242 ENDIF 243 DO jl = 1, ipl; DO jk = 1, ipk 244 DO jj = 1, nn_hls 245 ijj = jpj-jj+1 246 DO ji = 1, endloop 247 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 248 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 249 END DO 250 END DO 251 END DO; END DO 252 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 253 DO jl = 1, ipl; DO jk = 1, ipk 254 DO jj = 1, nn_hls 255 ijj = jpj-jj+1 256 DO ii = 1, nn_hls 257 iij = jpi-ii+1 258 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl) 259 END DO 260 END DO 261 END DO; END DO 262 ENDIF 263 ! 264 CASE ( 'V' ) ! V-point 265 DO jl = 1, ipl; DO jk = 1, ipk 266 DO jj = 1, nn_hls 267 ijj = jpj -jj +1 268 DO ji = 1, jpi 269 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 270 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 271 END DO 272 END DO 273 END DO; END DO 274 275 IF ( .NOT. l_fast_exchanges ) THEN 276 IF( nimpp >= Ni0glo/2+2 ) THEN 277 startloop = 1 278 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 279 startloop = Ni0glo/2+2 - nimpp + nn_hls 280 ELSE 281 startloop = jpi + 1 282 ENDIF 283 IF( startloop <= jpi ) THEN 166 284 DO jl = 1, ipl; DO jk = 1, ipk 167 DO jj = 2, nn_hls+1 168 ijj = jpj -jj +1 169 DO ji = startloop, jpi 170 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 171 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 172 END DO 173 END DO 285 DO ji = startloop, jpi 286 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 287 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl) 288 END DO 174 289 END DO; END DO 175 290 ENDIF 176 DO jl = 1, ipl; DO jk = 1, ipk 177 DO ji = startloop, jpi 178 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 179 ARRAY_IN(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 180 END DO 181 END DO; END DO 182 IF (nimpp .eq. 1) THEN 183 DO jj = 1, nn_hls 184 ijj = jpj-jj+1 185 DO ii = 0, nn_hls-1 186 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:) 187 END DO 188 END DO 189 ENDIF 190 CASE ( 'F' ) ! F-point 291 ENDIF 292 ! 293 CASE ( 'F' ) ! F-point 294 IF( nimpp + jpi - 1 /= jpiglo ) THEN 295 endloop = jpi 296 ELSE 297 endloop = jpi - nn_hls 298 ENDIF 299 DO jl = 1, ipl; DO jk = 1, ipk 300 DO jj = 1, nn_hls 301 ijj = jpj -jj +1 302 DO ji = 1, endloop 303 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 304 ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 305 END DO 306 END DO 307 END DO; END DO 308 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 309 DO jl = 1, ipl; DO jk = 1, ipk 310 DO jj = 1, nn_hls 311 ijj = jpj -jj +1 312 DO ii = 1, nn_hls 313 iij = jpi -ii+1 314 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl) 315 END DO 316 END DO 317 END DO; END DO 318 ENDIF 319 ! 320 IF ( .NOT. l_fast_exchanges ) THEN 191 321 IF( nimpp + jpi - 1 /= jpiglo ) THEN 192 322 endloop = jpi … … 194 324 endloop = jpi - nn_hls 195 325 ENDIF 196 IF ( .NOT. l_fast_exchanges ) THEN 326 IF( nimpp >= Ni0glo/2+2 ) THEN 327 startloop = 1 328 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 329 startloop = Ni0glo/2+2 - nimpp + nn_hls 330 ELSE 331 startloop = endloop + 1 332 ENDIF 333 IF( startloop <= endloop ) THEN 197 334 DO jl = 1, ipl; DO jk = 1, ipk 198 DO jj = 2, nn_hls+1 199 ijj = jpj -jj +1 200 DO ji = 1, endloop 201 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 202 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 203 END DO 204 END DO 335 DO ji = startloop, endloop 336 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 337 ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl) 338 END DO 205 339 END DO; END DO 206 340 ENDIF 207 DO jl = 1, ipl; DO jk = 1, ipk 208 DO ji = 1, endloop 209 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 210 ARRAY_IN(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 211 END DO 212 END DO; END DO 213 IF (nimpp .eq. 1) THEN 214 DO ii = 1, nn_hls 215 ARRAY_IN(ii,jpj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:) 216 END DO 217 IF ( .NOT. l_fast_exchanges ) THEN 218 DO jj = 1, nn_hls 219 ijj = jpj -jj 220 DO ii = 0, nn_hls-1 221 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 222 END DO 223 END DO 224 ENDIF 225 ENDIF 226 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 227 DO ii = 1, nn_hls 228 ARRAY_IN(jpi-ii+1,jpj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:) 229 END DO 230 IF ( .NOT. l_fast_exchanges ) THEN 231 DO jj = 1, nn_hls 232 ijj = jpj -jj 233 DO ii = 1, nn_hls 234 ARRAY_IN(jpi-ii+1,ijj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 235 END DO 236 END DO 237 ENDIF 238 ENDIF 239 ! 240 END SELECT 241 ! 242 ENDIF ! c_NFtype == 'T' 341 ENDIF 342 ! 343 END SELECT 243 344 ! 244 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 245 ! 246 SELECT CASE ( cd_nat ) 247 CASE ( 'T' , 'W' ) ! T-, W-point 248 DO jl = 1, ipl; DO jk = 1, ipk 249 DO jj = 1, nn_hls 250 ijj = jpj-jj+1 251 DO ji = 1, jpi 252 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 253 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 254 END DO 255 END DO 256 END DO; END DO 257 ! 258 CASE ( 'U' ) ! U-point 259 IF( nimpp + jpi - 1 /= jpiglo ) THEN 260 endloop = jpi 261 ELSE 262 endloop = jpi - nn_hls 263 ENDIF 264 DO jl = 1, ipl; DO jk = 1, ipk 265 DO jj = 1, nn_hls 266 ijj = jpj-jj+1 267 DO ji = 1, endloop 268 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 269 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 270 END DO 271 END DO 272 END DO; END DO 273 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 274 DO jl = 1, ipl; DO jk = 1, ipk 275 DO jj = 1, nn_hls 276 ijj = jpj-jj+1 277 DO ii = 1, nn_hls 278 iij = jpi-ii+1 279 ARRAY_IN(iij,ijj,jk,jl) = psgn * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl) 280 END DO 281 END DO 282 END DO; END DO 283 ENDIF 284 ! 285 CASE ( 'V' ) ! V-point 286 DO jl = 1, ipl; DO jk = 1, ipk 287 DO jj = 1, nn_hls 288 ijj = jpj -jj +1 289 DO ji = 1, jpi 290 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 291 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 292 END DO 293 END DO 294 END DO; END DO 345 ENDIF ! c_NFtype == 'F' 346 ! 347 END SUBROUTINE lbc_nfd_nogather_/**/PRECISION 295 348 296 IF ( .NOT. l_fast_exchanges ) THEN297 IF( nimpp >= Ni0glo/2+2 ) THEN298 startloop = 1299 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN300 startloop = Ni0glo/2+2 - nimpp + nn_hls301 ELSE302 startloop = jpi + 1303 ENDIF304 IF( startloop <= jpi ) THEN305 DO jl = 1, ipl; DO jk = 1, ipk306 DO ji = startloop, jpi307 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3308 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl)309 END DO310 END DO; END DO311 ENDIF312 ENDIF313 !314 CASE ( 'F' ) ! F-point315 IF( nimpp + jpi - 1 /= jpiglo ) THEN316 endloop = jpi317 ELSE318 endloop = jpi - nn_hls319 ENDIF320 DO jl = 1, ipl; DO jk = 1, ipk321 DO jj = 1, nn_hls322 ijj = jpj -jj +1323 DO ji = 1, endloop324 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2325 ARRAY_IN(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl)326 END DO327 END DO328 END DO; END DO329 IF((nimpp + jpi - 1) .eq. jpiglo) THEN330 DO jl = 1, ipl; DO jk = 1, ipk331 DO jj = 1, nn_hls332 ijj = jpj -jj +1333 DO ii = 1, nn_hls334 iij = jpi -ii+1335 ARRAY_IN(iij,ijj,jk,jl) = psgn * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl)336 END DO337 END DO338 END DO; END DO339 ENDIF340 !341 IF ( .NOT. l_fast_exchanges ) THEN342 IF( nimpp + jpi - 1 /= jpiglo ) THEN343 endloop = jpi344 ELSE345 endloop = jpi - nn_hls346 ENDIF347 IF( nimpp >= Ni0glo/2+2 ) THEN348 startloop = 1349 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN350 startloop = Ni0glo/2+2 - nimpp + nn_hls351 ELSE352 startloop = endloop + 1353 ENDIF354 IF( startloop <= endloop ) THEN355 DO jl = 1, ipl; DO jk = 1, ipk356 DO ji = startloop, endloop357 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2358 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl)359 END DO360 END DO; END DO361 ENDIF362 ENDIF363 !364 END SELECT365 !366 ENDIF ! c_NFtype == 'F'367 !368 END SUBROUTINE lbc_nfd_nogather_/**/XD/**/_/**/PRECISION369 370 #undef XD371 #undef DIMS_IN372 #undef ARRAY_IN373 #undef K_SIZE374 #undef L_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbclnk.F90
r14338 r14349 36 36 37 37 INTERFACE lbc_lnk_pt2pt 38 MODULE PROCEDURE lbc_lnk_pt2pt_2d_sp , lbc_lnk_pt2pt_3d_sp , lbc_lnk_pt2pt_4d_sp 39 MODULE PROCEDURE lbc_lnk_pt2pt_2d_dp , lbc_lnk_pt2pt_3d_dp , lbc_lnk_pt2pt_4d_dp 38 MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp 40 39 END INTERFACE 41 40 42 41 INTERFACE lbc_lnk_neicoll 43 MODULE PROCEDURE lbc_lnk_neicoll_2d_sp , lbc_lnk_neicoll_3d_sp , lbc_lnk_neicoll_4d_sp 44 MODULE PROCEDURE lbc_lnk_neicoll_2d_dp , lbc_lnk_neicoll_3d_dp , lbc_lnk_neicoll_4d_dp 42 MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp 45 43 END INTERFACE 46 44 ! … … 111 109 ! 112 110 !!---------------------------------------------------------------------- 113 !! *** lbc_lnk_pt2pt_[ 234]d_[sd]p ***114 !! *** lbc_lnk_neicoll_[ 234]d_[sd]p ***111 !! *** lbc_lnk_pt2pt_[sd]p *** 112 !! *** lbc_lnk_neicoll_[sd]p *** 115 113 !! 116 114 !! * Argument : dummy argument use in lbc_lnk_... routines … … 127 125 !! 128 126 #define PRECISION sp 129 # define MPI_TYPE MPI_REAL 130 # define DIM_2d 131 # include "lbc_lnk_pt2pt_generic.h90" 132 # include "lbc_lnk_neicoll_generic.h90" 133 # undef DIM_2d 134 # define DIM_3d 135 # include "lbc_lnk_pt2pt_generic.h90" 136 # include "lbc_lnk_neicoll_generic.h90" 137 # undef DIM_3d 138 # define DIM_4d 139 # include "lbc_lnk_pt2pt_generic.h90" 140 # include "lbc_lnk_neicoll_generic.h90" 141 # undef DIM_4d 142 # undef MPI_TYPE 127 # define MPI_TYPE MPI_REAL 128 # include "lbc_lnk_pt2pt_generic.h90" 129 # include "lbc_lnk_neicoll_generic.h90" 130 # undef MPI_TYPE 143 131 #undef PRECISION 144 132 !! … … 146 134 !! 147 135 #define PRECISION dp 148 # define MPI_TYPE MPI_DOUBLE_PRECISION 149 # define DIM_2d 150 # include "lbc_lnk_pt2pt_generic.h90" 151 # include "lbc_lnk_neicoll_generic.h90" 152 # undef DIM_2d 153 # define DIM_3d 154 # include "lbc_lnk_pt2pt_generic.h90" 155 # include "lbc_lnk_neicoll_generic.h90" 156 # undef DIM_3d 157 # define DIM_4d 158 # include "lbc_lnk_pt2pt_generic.h90" 159 # include "lbc_lnk_neicoll_generic.h90" 160 # undef DIM_4d 161 # undef MPI_TYPE 136 # define MPI_TYPE MPI_DOUBLE_PRECISION 137 # include "lbc_lnk_pt2pt_generic.h90" 138 # include "lbc_lnk_neicoll_generic.h90" 139 # undef MPI_TYPE 162 140 #undef PRECISION 163 141 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbcnfd.F90
r14338 r14349 28 28 PRIVATE 29 29 30 INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt, lbc_lnk_neicoll 31 MODULE PROCEDURE lbc_nfd_2d_sp, lbc_nfd_ext_2d_sp, lbc_nfd_3d_sp, lbc_nfd_4d_sp 32 MODULE PROCEDURE lbc_nfd_2d_dp, lbc_nfd_ext_2d_dp, lbc_nfd_3d_dp, lbc_nfd_4d_dp 30 INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll 31 MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp 32 MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp 33 END INTERFACE 34 35 INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll 36 MODULE PROCEDURE mpp_nfd_sp, mpp_nfd_dp 33 37 END INTERFACE 34 38 35 39 INTERFACE lbc_nfd_nogather ! called by mpp_nfd 36 MODULE PROCEDURE lbc_nfd_nogather_2d_sp, lbc_nfd_nogather_3d_sp, lbc_nfd_nogather_4d_sp 37 MODULE PROCEDURE lbc_nfd_nogather_2d_dp, lbc_nfd_nogather_3d_dp, lbc_nfd_nogather_4d_dp 38 END INTERFACE 39 40 INTERFACE mpp_nfd 41 MODULE PROCEDURE mpp_nfd_2d_sp, mpp_nfd_3d_sp, mpp_nfd_4d_sp 42 MODULE PROCEDURE mpp_nfd_2d_dp, mpp_nfd_3d_dp, mpp_nfd_4d_dp 40 MODULE PROCEDURE lbc_nfd_nogather_sp, lbc_nfd_nogather_dp 43 41 END INTERFACE 44 42 … … 60 58 61 59 !!---------------------------------------------------------------------- 62 !! *** routine lbc_nfd_[ 234]d_[sd]p ***63 !! *** routine lbc_nfd_nogather_[ 234]d_[sd]p ***64 !! *** routine lbc_nfd_ext_ 2d_[sd]p ***60 !! *** routine lbc_nfd_[sd]p *** 61 !! *** routine lbc_nfd_nogather_[sd]p *** 62 !! *** routine lbc_nfd_ext_[sd]p *** 65 63 !!---------------------------------------------------------------------- 66 64 !! … … 76 74 ! 77 75 #define PRECISION sp 78 # define DIM_2d 79 # include "lbc_nfd_generic.h90" 80 # include "lbc_nfd_nogather_generic.h90" 81 # include "lbc_nfd_ext_generic.h90" 82 # undef DIM_2d 83 # define DIM_3d 84 # include "lbc_nfd_generic.h90" 85 # include "lbc_nfd_nogather_generic.h90" 86 # undef DIM_3d 87 # define DIM_4d 88 # include "lbc_nfd_generic.h90" 89 # include "lbc_nfd_nogather_generic.h90" 90 # undef DIM_4d 76 # include "lbc_nfd_generic.h90" 77 # include "lbc_nfd_nogather_generic.h90" 78 # include "lbc_nfd_ext_generic.h90" 91 79 #undef PRECISION 92 80 ! … … 94 82 ! 95 83 #define PRECISION dp 96 # define DIM_2d 97 # include "lbc_nfd_generic.h90" 98 # include "lbc_nfd_nogather_generic.h90" 99 # include "lbc_nfd_ext_generic.h90" 100 # undef DIM_2d 101 # define DIM_3d 102 # include "lbc_nfd_generic.h90" 103 # include "lbc_nfd_nogather_generic.h90" 104 # undef DIM_3d 105 # define DIM_4d 106 # include "lbc_nfd_generic.h90" 107 # include "lbc_nfd_nogather_generic.h90" 108 # undef DIM_4d 84 # include "lbc_nfd_generic.h90" 85 # include "lbc_nfd_nogather_generic.h90" 86 # include "lbc_nfd_ext_generic.h90" 109 87 #undef PRECISION 110 88 … … 112 90 ! 113 91 !!---------------------------------------------------------------------- 114 !! *** routine mpp_nfd_ (2,3,4)d***92 !! *** routine mpp_nfd_[sd]p *** 115 93 !! 116 94 !! * Argument : dummy argument use in mpp_nfd_... routines … … 126 104 !! 127 105 #define PRECISION sp 128 # define MPI_TYPE MPI_REAL 129 # define DIM_2d 130 # include "mpp_nfd_generic.h90" 131 # undef DIM_2d 132 # define DIM_3d 133 # include "mpp_nfd_generic.h90" 134 # undef DIM_3d 135 # define DIM_4d 136 # include "mpp_nfd_generic.h90" 137 # undef DIM_4d 138 # undef MPI_TYPE 106 # define MPI_TYPE MPI_REAL 107 # include "mpp_nfd_generic.h90" 108 # undef MPI_TYPE 139 109 #undef PRECISION 140 110 !! … … 142 112 !! 143 113 #define PRECISION dp 144 # define MPI_TYPE MPI_DOUBLE_PRECISION 145 # define DIM_2d 146 # include "mpp_nfd_generic.h90" 147 # undef DIM_2d 148 # define DIM_3d 149 # include "mpp_nfd_generic.h90" 150 # undef DIM_3d 151 # define DIM_4d 152 # include "mpp_nfd_generic.h90" 153 # undef DIM_4d 154 # undef MPI_TYPE 114 # define MPI_TYPE MPI_DOUBLE_PRECISION 115 # include "mpp_nfd_generic.h90" 116 # undef MPI_TYPE 155 117 #undef PRECISION 156 118 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lib_mpp.F90
r14338 r14349 110 110 END INTERFACE 111 111 112 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (used in lbclnk and lbcnfd)113 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d114 END TYPE PTR_2D_sp115 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (used in lbclnk and lbcnfd)116 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d117 END TYPE PTR_3D_sp118 112 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) 119 113 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 120 114 END TYPE PTR_4D_sp 121 115 122 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (used in lbclnk and lbcnfd)123 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d124 END TYPE PTR_2D_dp125 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (used in lbclnk and lbcnfd)126 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d127 END TYPE PTR_3D_dp128 116 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) 129 117 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nfd_generic.h90
r14338 r14349 1 #if defined DIM_2d2 # define XD 2d3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)4 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,1:1,1:1)5 # define K_SIZE(ptab) 16 # define L_SIZE(ptab) 17 #endif8 #if defined DIM_3d9 # define XD 3d10 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)11 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,k,1:1)12 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)13 # define L_SIZE(ptab) 114 #endif15 #if defined DIM_4d16 # define XD 4d17 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)18 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,k,l)19 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)20 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)21 #endif22 #define F_SIZE(ptab) kfld23 1 24 SUBROUTINE mpp_nfd_/**/ XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld )25 TYPE(PTR_ /**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.2 SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 26 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 27 5 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary … … 52 30 !!---------------------------------------------------------------------- 53 31 ! 54 ipk = K_SIZE(ptab) ! 3rd dimension55 ipl = L_SIZE(ptab) ! 4th -56 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)32 ipk = SIZE(ptab(1)%pt4d,3) 33 ipl = SIZE(ptab(1)%pt4d,4) 34 ipf = kfld 57 35 ! 58 36 IF( ln_nnogather ) THEN !== no allgather exchanges ==! … … 129 107 ij2 = jj_s(jj,jf) 130 108 DO ji = 1, jpi 131 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)109 ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 132 110 END DO 133 111 DO ji = jpi+1, jpimax … … 177 155 ij2 = jj_s(jj,jf) 178 156 DO ji = iis0, iie0 179 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point157 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st iner domain point 180 158 END DO 181 159 END DO … … 198 176 ij2 = jj_s(jj,jf) 199 177 DO ji = iis0, iie0 200 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)178 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 201 179 END DO 202 180 END DO … … 227 205 ij1 = jj_b( 1 ,jf) 228 206 ij2 = jj_b(ipj_s(jf),jf) 229 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf) )207 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf) ) 230 208 END DO 231 209 ! … … 256 234 DO ji = 1, Ni_0 257 235 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 258 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf)236 znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) 259 237 END DO 260 238 DO ji = Ni_0+1, i0max … … 293 271 DO ji = 1, ipi 294 272 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 295 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point273 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 296 274 END DO 297 275 END DO … … 340 318 DO ji= 1, jpi 341 319 ii2 = mig(ji) 342 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl)320 ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) 343 321 END DO 344 322 END DO … … 352 330 ENDIF ! l_north_nogather 353 331 ! 354 END SUBROUTINE mpp_nfd_/**/ XD/**/_/**/PRECISION332 END SUBROUTINE mpp_nfd_/**/PRECISION 355 333 356 #undef XD357 #undef ARRAY_IN358 #undef ARRAY_LOCAL359 #undef K_SIZE360 #undef L_SIZE361 #undef F_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/tests/TSUNAMI/MY_SRC/usrdef_sbc.F90
r14225 r14349 3 3 !! *** MODULE usrdef_sbc *** 4 4 !! 5 !! === CANALconfiguration ===5 !! === TSUNAMI configuration === 6 6 !! 7 7 !! User defined : surface forcing of a user configuration … … 44 44 !! condition, i.e. the momentum, heat and freshwater fluxes. 45 45 !! 46 !! ** Method : all 0 fields, for CANALcase46 !! ** Method : all 0 fields, for TSUNAMI case 47 47 !! CAUTION : never mask the surface stress field ! 48 48 !! … … 57 57 IF( kt == nit000 ) THEN 58 58 ! 59 IF(lwp) WRITE(numout,*)' usr_sbc : EW_CANALcase: surface forcing'59 IF(lwp) WRITE(numout,*)' usr_sbc : TSUNAMI case: surface forcing' 60 60 IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ vtau = taum = wndm = qns = qsr = emp = sfx = 0' 61 61 !
Note: See TracChangeset
for help on using the changeset viewer.
