Changeset 14433 for NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
- Timestamp:
- 2021-02-11T09:06:49+01:00 (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13286 r14433 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # if defined DIM_2d 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define K_SIZE(ptab) 1 13 # define L_SIZE(ptab) 1 14 # endif 15 # if defined DIM_3d 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 # define L_SIZE(ptab) 1 24 # endif 25 # if defined DIM_4d 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 34 # endif 35 # if defined SINGLE_PRECISION 36 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 37 # else 38 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 39 # endif 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) 42 #else 43 ! !== IN: ptab is an array ==! 44 # define NAT_IN(k) cd_nat 45 # define SGN_IN(k) psgn 46 # define F_SIZE(ptab) 1 47 # if defined DIM_2d 48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 49 # define K_SIZE(ptab) 1 50 # define L_SIZE(ptab) 1 51 # endif 52 # if defined DIM_3d 53 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 54 # define K_SIZE(ptab) SIZE(ptab,3) 55 # define L_SIZE(ptab) 1 56 # endif 57 # if defined DIM_4d 58 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 59 # define K_SIZE(ptab) SIZE(ptab,3) 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 # endif 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 # if defined SINGLE_PRECISION 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 66 # define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 67 # else 68 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 69 # define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 70 # endif 71 # endif 72 # ifdef SINGLE_PRECISION 73 # define PRECISION sp 74 # else 75 # define PRECISION dp 76 # endif 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 1 2 SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn, khls ) 78 3 !!---------------------------------------------------------------------- 79 4 !! … … 82 7 !! 83 8 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:)85 ARRAY2_TYPE(:,:,:,:,:)86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:)! nature of array grid-points87 REAL( wp) , INTENT(in ) :: SGN_IN(:)! sign used across the north fold boundary88 INTEGER , OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays89 ! 90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf! dummy loop indices91 INTEGER :: ip i, ipj, ipk, ipl, ipf, iij, ijj! dimension of the input array9 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 13 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 14 ! 15 INTEGER :: ji, jj, jk, jn, jl, jh ! dummy loop indices 16 INTEGER :: ipk, ipl, ii, iij, ijj ! dimension of the input array 92 17 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 18 LOGICAL :: l_fast_exchanges 94 19 !!---------------------------------------------------------------------- 95 ipj = J_SIZE(ptab2) ! 2nd dimension of input array 96 ipk = K_SIZE(ptab) ! 3rd dimension of output array 97 ipl = L_SIZE(ptab) ! 4th - 98 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 99 ! 100 ! Security check for further developments 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 20 ipk = SIZE(ptab,3) 21 ipl = SIZE(ptab,4) 22 ! 102 23 ! 2nd dimension determines exchange speed 103 IF (ipj == 1 ) THEN 104 l_fast_exchanges = .TRUE. 105 ELSE 106 l_fast_exchanges = .FALSE. 107 ENDIF 108 ! 109 DO jf = 1, ipf ! Loop over the number of arrays to be processed 24 l_fast_exchanges = SIZE(ptab2,2) == 1 25 ! 26 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 110 27 ! 111 SELECT CASE ( npolj ) 112 ! 113 CASE ( 3, 4 ) ! * North fold T-point pivot 114 ! 115 SELECT CASE ( NAT_IN(jf) ) 116 ! 117 CASE ( 'T' , 'W' ) ! T-, W-point 118 IF ( nimpp /= 1 ) THEN ; startloop = 1 119 ELSE ; startloop = 1 + nn_hls 120 ENDIF 121 ! 122 DO jl = 1, ipl; DO jk = 1, ipk 123 DO jj = 1, nn_hls 124 ijj = jpj -jj +1 28 SELECT CASE ( cd_nat ) 29 ! 30 CASE ( 'T' , 'W' ) ! T-, W-point 31 IF ( nimpp /= 1 ) THEN ; startloop = 1 32 ELSE ; startloop = 1 + khls 33 ENDIF 34 ! 35 DO jl = 1, ipl; DO jk = 1, ipk 36 DO jj = 1, khls 37 ijj = jpj -jj +1 38 DO ji = startloop, jpi 39 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 40 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 41 END DO 42 END DO 43 END DO; END DO 44 IF( nimpp == 1 ) THEN 45 DO jl = 1, ipl; DO jk = 1, ipk 46 DO jj = 1, khls 47 ijj = jpj -jj +1 48 DO ii = 0, khls-1 49 ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,jk,jl) 50 END DO 51 END DO 52 END DO; END DO 53 ENDIF 54 ! 55 IF ( .NOT. l_fast_exchanges ) THEN 56 IF( nimpp >= Ni0glo/2+2 ) THEN 57 startloop = 1 58 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 59 startloop = Ni0glo/2+2 - nimpp + khls 60 ELSE 61 startloop = jpi + 1 62 ENDIF 63 IF( startloop <= jpi ) THEN 64 DO jl = 1, ipl; DO jk = 1, ipk 125 65 DO ji = startloop, jpi 126 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 127 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 128 END DO 129 END DO 130 END DO; END DO 131 IF( nimpp == 1 ) THEN 132 DO jl = 1, ipl; DO jk = 1, ipk 133 DO jj = 1, nn_hls 134 ijj = jpj -jj +1 135 DO ii = 0, nn_hls-1 136 ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf) 137 END DO 66 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 67 jia = ji + nimpp - 1 68 ijta = jpiglo - jia + 2 69 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 70 ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijta-nimpp+khls,jpj-khls,jk,jl) 71 ELSE 72 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 73 ENDIF 138 74 END DO 139 75 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 144 startloop = 1 145 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 146 startloop = Ni0glo/2+2 - nimpp + nn_hls 147 ELSE 148 startloop = jpi + 1 149 ENDIF 150 IF( startloop <= jpi ) THEN 151 DO jl = 1, ipl; DO jk = 1, ipk 152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 154 jia = ji + nimpp - 1 155 ijta = jpiglo - jia + 2 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 157 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf) 158 ELSE 159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 160 ENDIF 161 END DO 162 END DO; END DO 163 ENDIF 164 ENDIF 165 CASE ( 'U' ) ! U-point 76 ENDIF 77 ENDIF 78 CASE ( 'U' ) ! U-point 79 IF( nimpp + jpi - 1 /= jpiglo ) THEN 80 endloop = jpi 81 ELSE 82 endloop = jpi - khls 83 ENDIF 84 DO jl = 1, ipl; DO jk = 1, ipk 85 DO jj = 1, khls 86 ijj = jpj -jj +1 87 DO ji = 1, endloop 88 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 89 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 90 END DO 91 END DO 92 END DO; END DO 93 IF (nimpp .eq. 1) THEN 94 DO jj = 1, khls 95 ijj = jpj -jj +1 96 DO ii = 0, khls-1 97 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 98 END DO 99 END DO 100 ENDIF 101 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 102 DO jj = 1, khls 103 ijj = jpj -jj +1 104 DO ii = 1, khls 105 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 106 END DO 107 END DO 108 ENDIF 109 ! 110 IF ( .NOT. l_fast_exchanges ) THEN 166 111 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 112 endloop = jpi 168 113 ELSE 169 endloop = jpi - nn_hls 170 ENDIF 171 DO jl = 1, ipl; DO jk = 1, ipk 172 DO jj = 1, nn_hls 173 ijj = jpj -jj +1 174 DO ji = 1, endloop 175 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 176 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 177 END DO 178 END DO 179 END DO; END DO 180 IF (nimpp .eq. 1) THEN 181 DO jj = 1, nn_hls 182 ijj = jpj -jj +1 183 DO ii = 0, nn_hls-1 184 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 185 END DO 186 END DO 187 ENDIF 188 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 189 DO jj = 1, nn_hls 190 ijj = jpj -jj +1 191 DO ii = 1, nn_hls 192 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 193 END DO 194 END DO 195 ENDIF 196 ! 197 IF ( .NOT. l_fast_exchanges ) THEN 198 IF( nimpp + jpi - 1 /= jpiglo ) THEN 199 endloop = jpi 200 ELSE 201 endloop = jpi - nn_hls 202 ENDIF 203 IF( nimpp >= Ni0glo/2+1 ) THEN 204 startloop = nn_hls 205 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 206 startloop = Ni0glo/2+1 - nimpp + nn_hls 207 ELSE 208 startloop = endloop + 1 209 ENDIF 210 IF( startloop <= endloop ) THEN 114 endloop = jpi - khls 115 ENDIF 116 IF( nimpp >= Ni0glo/2+1 ) THEN 117 startloop = khls 118 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 119 startloop = Ni0glo/2+1 - nimpp + khls 120 ELSE 121 startloop = endloop + 1 122 ENDIF 123 IF( startloop <= endloop ) THEN 211 124 DO jl = 1, ipl; DO jk = 1, ipk 212 125 DO ji = startloop, endloop … … 215 128 ijua = jpiglo - jia + 1 216 129 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf)130 ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-khls,jk,jl) 218 131 ELSE 219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)132 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 220 133 ENDIF 221 134 END DO 222 135 END DO; END DO 223 ENDIF 224 ENDIF 225 ! 226 CASE ( 'V' ) ! V-point 227 IF( nimpp /= 1 ) THEN 228 startloop = 1 229 ELSE 230 startloop = 1 + nn_hls 231 ENDIF 136 ENDIF 137 ENDIF 138 ! 139 CASE ( 'V' ) ! V-point 140 IF( nimpp /= 1 ) THEN 141 startloop = 1 142 ELSE 143 startloop = 1 + khls 144 ENDIF 145 IF ( .NOT. l_fast_exchanges ) THEN 146 DO jl = 1, ipl; DO jk = 1, ipk 147 DO jj = 2, khls+1 148 ijj = jpj -jj +1 149 DO ji = startloop, jpi 150 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 151 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 152 END DO 153 END DO 154 END DO; END DO 155 ENDIF 156 DO jl = 1, ipl; DO jk = 1, ipk 157 DO ji = startloop, jpi 158 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 159 ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 160 END DO 161 END DO; END DO 162 IF (nimpp .eq. 1) THEN 163 DO jj = 1, khls 164 ijj = jpj-jj+1 165 DO ii = 0, khls-1 166 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,:,:) 167 END DO 168 END DO 169 ENDIF 170 CASE ( 'F' ) ! F-point 171 IF( nimpp + jpi - 1 /= jpiglo ) THEN 172 endloop = jpi 173 ELSE 174 endloop = jpi - khls 175 ENDIF 176 IF ( .NOT. l_fast_exchanges ) THEN 177 DO jl = 1, ipl; DO jk = 1, ipk 178 DO jj = 2, khls+1 179 ijj = jpj -jj +1 180 DO ji = 1, endloop 181 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 182 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 183 END DO 184 END DO 185 END DO; END DO 186 ENDIF 187 DO jl = 1, ipl; DO jk = 1, ipk 188 DO ji = 1, endloop 189 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 190 ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 191 END DO 192 END DO; END DO 193 IF (nimpp .eq. 1) THEN 194 DO ii = 1, khls 195 ptab(ii,jpj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls-1,:,:) 196 END DO 232 197 IF ( .NOT. l_fast_exchanges ) THEN 198 DO jj = 1, khls 199 ijj = jpj -jj 200 DO ii = 0, khls-1 201 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 202 END DO 203 END DO 204 ENDIF 205 ENDIF 206 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 207 DO ii = 1, khls 208 ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls-1,:,:) 209 END DO 210 IF ( .NOT. l_fast_exchanges ) THEN 211 DO jj = 1, khls 212 ijj = jpj -jj 213 DO ii = 1, khls 214 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 215 END DO 216 END DO 217 ENDIF 218 ENDIF 219 ! 220 END SELECT 221 ! 222 ENDIF ! c_NFtype == 'T' 223 ! 224 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 225 ! 226 SELECT CASE ( cd_nat ) 227 CASE ( 'T' , 'W' ) ! T-, W-point 228 DO jl = 1, ipl; DO jk = 1, ipk 229 DO jj = 1, khls 230 ijj = jpj-jj+1 231 DO ji = 1, jpi 232 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 233 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 234 END DO 235 END DO 236 END DO; END DO 237 ! 238 CASE ( 'U' ) ! U-point 239 IF( nimpp + jpi - 1 /= jpiglo ) THEN 240 endloop = jpi 241 ELSE 242 endloop = jpi - khls 243 ENDIF 244 DO jl = 1, ipl; DO jk = 1, ipk 245 DO jj = 1, khls 246 ijj = jpj-jj+1 247 DO ji = 1, endloop 248 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 249 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 250 END DO 251 END DO 252 END DO; END DO 253 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 254 DO jl = 1, ipl; DO jk = 1, ipk 255 DO jj = 1, khls 256 ijj = jpj-jj+1 257 DO ii = 1, khls 258 iij = jpi-ii+1 259 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj,jk,jl) 260 END DO 261 END DO 262 END DO; END DO 263 ENDIF 264 ! 265 CASE ( 'V' ) ! V-point 266 DO jl = 1, ipl; DO jk = 1, ipk 267 DO jj = 1, khls 268 ijj = jpj -jj +1 269 DO ji = 1, jpi 270 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 271 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 272 END DO 273 END DO 274 END DO; END DO 275 276 IF ( .NOT. l_fast_exchanges ) THEN 277 IF( nimpp >= Ni0glo/2+2 ) THEN 278 startloop = 1 279 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 280 startloop = Ni0glo/2+2 - nimpp + khls 281 ELSE 282 startloop = jpi + 1 283 ENDIF 284 IF( startloop <= jpi ) THEN 233 285 DO jl = 1, ipl; DO jk = 1, ipk 234 DO jj = 2, nn_hls+1 235 ijj = jpj -jj +1 236 DO ji = startloop, jpi 237 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 238 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 239 END DO 240 END DO 286 DO ji = startloop, jpi 287 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 288 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 289 END DO 241 290 END DO; END DO 242 291 ENDIF 243 DO jl = 1, ipl; DO jk = 1, ipk 244 DO ji = startloop, jpi 245 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 246 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 247 END DO 248 END DO; END DO 249 IF (nimpp .eq. 1) THEN 250 DO jj = 1, nn_hls 251 ijj = jpj-jj+1 252 DO ii = 0, nn_hls-1 253 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf) 254 END DO 255 END DO 256 ENDIF 257 CASE ( 'F' ) ! F-point 292 ENDIF 293 ! 294 CASE ( 'F' ) ! F-point 295 IF( nimpp + jpi - 1 /= jpiglo ) THEN 296 endloop = jpi 297 ELSE 298 endloop = jpi - khls 299 ENDIF 300 DO jl = 1, ipl; DO jk = 1, ipk 301 DO jj = 1, khls 302 ijj = jpj -jj +1 303 DO ji = 1, endloop 304 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 305 ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 306 END DO 307 END DO 308 END DO; END DO 309 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 310 DO jl = 1, ipl; DO jk = 1, ipk 311 DO jj = 1, khls 312 ijj = jpj -jj +1 313 DO ii = 1, khls 314 iij = jpi -ii+1 315 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj-1,jk,jl) 316 END DO 317 END DO 318 END DO; END DO 319 ENDIF 320 ! 321 IF ( .NOT. l_fast_exchanges ) THEN 258 322 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 323 endloop = jpi 260 324 ELSE 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 325 endloop = jpi - khls 326 ENDIF 327 IF( nimpp >= Ni0glo/2+2 ) THEN 328 startloop = 1 329 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 330 startloop = Ni0glo/2+2 - nimpp + khls 331 ELSE 332 startloop = endloop + 1 333 ENDIF 334 IF( startloop <= endloop ) THEN 264 335 DO jl = 1, ipl; DO jk = 1, ipk 265 DO jj = 2, nn_hls+1 266 ijj = jpj -jj +1 267 DO ji = 1, endloop 268 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 269 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 270 END DO 271 END DO 336 DO ji = startloop, endloop 337 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 338 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 339 END DO 272 340 END DO; END DO 273 341 ENDIF 274 DO jl = 1, ipl; DO jk = 1, ipk 275 DO ji = 1, endloop 276 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 277 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 278 END DO 279 END DO; END DO 280 IF (nimpp .eq. 1) THEN 281 DO ii = 1, nn_hls 282 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 283 END DO 284 IF ( .NOT. l_fast_exchanges ) THEN 285 DO jj = 1, nn_hls 286 ijj = jpj -jj 287 DO ii = 0, nn_hls-1 288 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 289 END DO 290 END DO 291 ENDIF 292 ENDIF 293 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 294 DO ii = 1, nn_hls 295 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 296 END DO 297 IF ( .NOT. l_fast_exchanges ) THEN 298 DO jj = 1, nn_hls 299 ijj = jpj -jj 300 DO ii = 1, nn_hls 301 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 302 END DO 303 END DO 304 ENDIF 305 ENDIF 306 ! 307 END SELECT 308 ! 309 CASE ( 5, 6 ) ! * North fold F-point pivot 310 ! 311 SELECT CASE ( NAT_IN(jf) ) 312 CASE ( 'T' , 'W' ) ! T-, W-point 313 DO jl = 1, ipl; DO jk = 1, ipk 314 DO jj = 1, nn_hls 315 ijj = jpj-jj+1 316 DO ji = 1, jpi 317 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 318 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 319 END DO 320 END DO 321 END DO; END DO 322 ! 323 CASE ( 'U' ) ! U-point 324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 326 ELSE 327 endloop = jpi - nn_hls 328 ENDIF 329 DO jl = 1, ipl; DO jk = 1, ipk 330 DO jj = 1, nn_hls 331 ijj = jpj-jj+1 332 DO ji = 1, endloop 333 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 334 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 335 END DO 336 END DO 337 END DO; END DO 338 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 339 DO jl = 1, ipl; DO jk = 1, ipk 340 DO jj = 1, nn_hls 341 ijj = jpj-jj+1 342 DO ii = 1, nn_hls 343 iij = jpi-ii+1 344 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf) 345 END DO 346 END DO 347 END DO; END DO 348 ENDIF 349 ! 350 CASE ( 'V' ) ! V-point 351 DO jl = 1, ipl; DO jk = 1, ipk 352 DO jj = 1, nn_hls 353 ijj = jpj -jj +1 354 DO ji = 1, jpi 355 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 356 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 357 END DO 358 END DO 359 END DO; END DO 342 ENDIF 343 ! 344 END SELECT 345 ! 346 ENDIF ! c_NFtype == 'F' 347 ! 348 END SUBROUTINE lbc_nfd_nogather_/**/PRECISION 360 349 361 IF ( .NOT. l_fast_exchanges ) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN363 startloop = 1364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN365 startloop = Ni0glo/2+2 - nimpp + nn_hls366 ELSE367 startloop = jpi + 1368 ENDIF369 IF( startloop <= jpi ) THEN370 DO jl = 1, ipl; DO jk = 1, ipk371 DO ji = startloop, jpi372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)374 END DO375 END DO; END DO376 ENDIF377 ENDIF378 !379 CASE ( 'F' ) ! F-point380 IF( nimpp + jpi - 1 /= jpiglo ) THEN381 endloop = jpi382 ELSE383 endloop = jpi - nn_hls384 ENDIF385 DO jl = 1, ipl; DO jk = 1, ipk386 DO jj = 1, nn_hls387 ijj = jpj -jj +1388 DO ji = 1, endloop389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)391 END DO392 END DO393 END DO; END DO394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN395 DO jl = 1, ipl; DO jk = 1, ipk396 DO jj = 1, nn_hls397 ijj = jpj -jj +1398 DO ii = 1, nn_hls399 iij = jpi -ii+1400 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf)401 END DO402 END DO403 END DO; END DO404 ENDIF405 !406 IF ( .NOT. l_fast_exchanges ) THEN407 IF( nimpp + jpi - 1 /= jpiglo ) THEN408 endloop = jpi409 ELSE410 endloop = jpi - nn_hls411 ENDIF412 IF( nimpp >= Ni0glo/2+2 ) THEN413 startloop = 1414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN415 startloop = Ni0glo/2+2 - nimpp + nn_hls416 ELSE417 startloop = endloop + 1418 ENDIF419 IF( startloop <= endloop ) THEN420 DO jl = 1, ipl; DO jk = 1, ipk421 DO ji = startloop, endloop422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)424 END DO425 END DO; END DO426 ENDIF427 ENDIF428 !429 END SELECT430 !431 CASE DEFAULT ! * closed : the code probably never go through432 !433 WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj434 !435 END SELECT ! npolj436 !437 END DO ! End jf loop438 END SUBROUTINE ROUTINE_NFD439 #undef PRECISION440 #undef ARRAY_TYPE441 #undef ARRAY_IN442 #undef NAT_IN443 #undef SGN_IN444 #undef J_SIZE445 #undef K_SIZE446 #undef L_SIZE447 #undef F_SIZE448 #undef ARRAY2_TYPE449 #undef ARRAY2_IN
Note: See TracChangeset
for help on using the changeset viewer.
