Changeset 10175
- Timestamp:
- 2018-10-05T17:20:12+02:00 (6 years ago)
- Location:
- NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC
- Files:
-
- 3 edited
-
lbc_nfd_nogather_generic.h90 (modified) (16 diffs)
-
lbcnfd.F90 (modified) (2 diffs)
-
mpp_nfd_generic.h90 (modified) (8 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r10173 r10175 8 8 # define K_SIZE(ptab) 1 9 9 # define L_SIZE(ptab) 1 10 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab2(f)11 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt2d(i,j)12 10 # endif 13 11 # if defined DIM_3d … … 16 14 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 17 15 # define L_SIZE(ptab) 1 18 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab2(f)19 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt3d(i,j,k)20 16 # endif 21 17 # if defined DIM_4d … … 24 20 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 25 21 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 26 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) 27 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) 28 # endif 22 # endif 23 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) 24 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 25 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) 29 26 #else 30 27 ! !== IN: ptab is an array ==! … … 36 33 # define K_SIZE(ptab) 1 37 34 # define L_SIZE(ptab) 1 38 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j)39 35 # endif 40 36 # if defined DIM_3d … … 42 38 # define K_SIZE(ptab) SIZE(ptab,3) 43 39 # define L_SIZE(ptab) 1 44 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k)45 40 # endif 46 41 # if defined DIM_4d … … 48 43 # define K_SIZE(ptab) SIZE(ptab,3) 49 44 # define L_SIZE(ptab) SIZE(ptab,4) 50 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 51 # endif 45 # endif 46 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 47 # define J_SIZE(ptab2) SIZE(ptab2,2) 52 48 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 53 49 # define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) … … 69 65 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 70 66 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 71 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 67 INTEGER :: ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop 68 LOGICAL :: l_fast_exchanges 72 69 !!---------------------------------------------------------------------- 73 ipk = K_SIZE(ptab) ! 3rd dimension 70 ipj = J_SIZE(ptab2) ! 2nd dimension of input array 71 ipk = K_SIZE(ptab) ! 3rd dimension of output array 74 72 ipl = L_SIZE(ptab) ! 4th - 75 73 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 76 74 ! 75 ! Security check for further developments 76 IF ( ipf > 1 ) THEN 77 write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation' 78 write(6,*) 'You should not be there...' 79 STOP 80 ENDIF 77 81 ! 78 SELECT CASE ( jpni ) 79 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 80 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 81 END SELECT 82 ijpjm1 = ijpj-1 83 ! 82 ijpj = 1 ! index of first modified line 83 ijpjp1 = 2 ! index + 1 84 85 ! 2nd dimension determines exchange speed 86 IF (ipj == 1 ) THEN 87 l_fast_exchanges = .TRUE. 88 ELSE 89 l_fast_exchanges = .FALSE. 90 ENDIF 84 91 ! 85 92 DO jf = 1, ipf ! Loop over the number of arrays to be processed … … 96 103 ENDIF 97 104 ! 98 DO ji = startloop, nlci 99 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 100 ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 101 END DO 105 DO jl = 1, ipl; DO jk = 1, ipk 106 DO ji = startloop, nlci 107 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 108 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 109 END DO 110 END DO; END DO 102 111 IF( nimpp == 1 ) THEN 103 ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-2,:,:,jf) 104 ENDIF 105 ! 106 IF( nimpp >= jpiglo/2+1 ) THEN 107 startloop = 1 108 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 109 startloop = jpiglo/2+1 - nimpp + 1 110 ELSE 111 startloop = nlci + 1 112 ENDIF 113 IF( startloop <= nlci ) THEN 114 DO ji = startloop, nlci 115 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 116 jia = ji + nimpp - 1 117 ijta = jpiglo - jia + 2 118 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 119 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,ijpjm1,:,:,jf) 120 ELSE 121 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf) 122 ENDIF 123 END DO 124 ENDIF 125 ! 112 DO jl = 1, ipl; DO jk = 1, ipk 113 ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 114 END DO; END DO 115 ENDIF 116 ! 117 IF ( .NOT. l_fast_exchanges ) THEN 118 IF( nimpp >= jpiglo/2+1 ) THEN 119 startloop = 1 120 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 121 startloop = jpiglo/2+1 - nimpp + 1 122 ELSE 123 startloop = nlci + 1 124 ENDIF 125 IF( startloop <= nlci ) THEN 126 DO jl = 1, ipl; DO jk = 1, ipk 127 DO ji = startloop, nlci 128 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 129 jia = ji + nimpp - 1 130 ijta = jpiglo - jia + 2 131 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 132 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf) 133 ELSE 134 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 135 ENDIF 136 END DO 137 END DO; END DO 138 ENDIF 139 ENDIF 140 126 141 CASE ( 'U' ) ! U-point 127 142 IF( nimpp + nlci - 1 /= jpiglo ) THEN … … 130 145 endloop = nlci - 1 131 146 ENDIF 132 DO ji = 1, endloop 133 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 134 ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 135 END DO 147 DO jl = 1, ipl; DO jk = 1, ipk 148 DO ji = 1, endloop 149 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 150 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 151 END DO 152 END DO; END DO 136 153 IF (nimpp .eq. 1) THEN 137 ARRAY_IN( 1 ,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-2,:,:,jf)154 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 138 155 ENDIF 139 156 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 140 ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf) 141 ENDIF 142 ! 143 IF( nimpp + nlci - 1 /= jpiglo ) THEN 144 endloop = nlci 145 ELSE 146 endloop = nlci - 1 147 ENDIF 148 IF( nimpp >= jpiglo/2 ) THEN 149 startloop = 1 150 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 151 startloop = jpiglo/2 - nimpp + 1 152 ELSE 153 startloop = endloop + 1 154 ENDIF 155 IF( startloop <= endloop ) THEN 156 DO ji = startloop, endloop 157 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 158 jia = ji + nimpp - 1 159 ijua = jpiglo - jia + 1 160 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 161 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,ijpjm1,:,:,jf) 162 ELSE 163 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf) 164 ENDIF 165 END DO 157 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 158 ENDIF 159 ! 160 IF ( .NOT. l_fast_exchanges ) THEN 161 IF( nimpp + nlci - 1 /= jpiglo ) THEN 162 endloop = nlci 163 ELSE 164 endloop = nlci - 1 165 ENDIF 166 IF( nimpp >= jpiglo/2 ) THEN 167 startloop = 1 168 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 169 startloop = jpiglo/2 - nimpp + 1 170 ELSE 171 startloop = endloop + 1 172 ENDIF 173 IF( startloop <= endloop ) THEN 174 DO jl = 1, ipl; DO jk = 1, ipk 175 DO ji = startloop, endloop 176 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 177 jia = ji + nimpp - 1 178 ijua = jpiglo - jia + 1 179 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 180 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf) 181 ELSE 182 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 183 ENDIF 184 END DO 185 END DO; END DO 186 ENDIF 166 187 ENDIF 167 188 ! … … 172 193 startloop = 2 173 194 ENDIF 174 DO ji = startloop, nlci 175 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 176 ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 177 ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-3,:,:,jf) 178 END DO 195 IF ( .NOT. l_fast_exchanges ) THEN 196 DO jl = 1, ipl; DO jk = 1, ipk 197 DO ji = startloop, nlci 198 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 199 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 200 END DO 201 END DO; END DO 202 ENDIF 203 DO jl = 1, ipl; DO jk = 1, ipk 204 DO ji = startloop, nlci 205 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 206 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 207 END DO 208 END DO; END DO 179 209 IF (nimpp .eq. 1) THEN 180 ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-3,:,:,jf)210 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 181 211 ENDIF 182 212 CASE ( 'F' ) ! F-point … … 186 216 endloop = nlci - 1 187 217 ENDIF 188 DO ji = 1, endloop 189 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 190 ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 191 ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-3,:,:,jf) 192 END DO 218 IF ( .NOT. l_fast_exchanges ) THEN 219 DO jl = 1, ipl; DO jk = 1, ipk 220 DO ji = 1, endloop 221 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 222 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 223 END DO 224 END DO; END DO 225 ENDIF 226 DO jl = 1, ipl; DO jk = 1, ipk 227 DO ji = 1, endloop 228 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 229 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 230 END DO 231 END DO; END DO 193 232 IF (nimpp .eq. 1) THEN 194 ARRAY_IN( 1 ,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-3,:,:,jf) 195 ARRAY_IN( 1 ,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-2,:,:,jf) 233 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 234 IF ( .NOT. l_fast_exchanges ) & 235 ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 196 236 ENDIF 197 237 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 198 ARRAY_IN(nlci,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-3,:,:,jf) 199 ARRAY_IN(nlci,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf) 238 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 239 IF ( .NOT. l_fast_exchanges ) & 240 ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 200 241 ENDIF 201 242 ! … … 206 247 SELECT CASE ( NAT_IN(jf) ) 207 248 CASE ( 'T' , 'W' ) ! T-, W-point 208 DO ji = 1, nlci 209 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 210 ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf) 211 END DO 249 DO jl = 1, ipl; DO jk = 1, ipk 250 DO ji = 1, nlci 251 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 252 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 253 END DO 254 END DO; END DO 212 255 ! 213 256 CASE ( 'U' ) ! U-point … … 217 260 endloop = nlci - 1 218 261 ENDIF 219 DO ji = 1, endloop 220 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 221 ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf) 222 END DO 262 DO jl = 1, ipl; DO jk = 1, ipk 263 DO ji = 1, endloop 264 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 265 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 266 END DO 267 END DO; END DO 223 268 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 224 ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-1,:,:,jf) 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 271 END DO; END DO 225 272 ENDIF 226 273 ! 227 274 CASE ( 'V' ) ! V-point 228 DO ji = 1, nlci 229 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 230 ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 231 END DO 232 ! 233 IF( nimpp >= jpiglo/2+1 ) THEN 234 startloop = 1 235 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 236 startloop = jpiglo/2+1 - nimpp + 1 237 ELSE 238 startloop = nlci + 1 239 ENDIF 240 IF( startloop <= nlci ) THEN 241 DO ji = startloop, nlci 242 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 243 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf) 244 END DO 275 DO jl = 1, ipl; DO jk = 1, ipk 276 DO ji = 1, nlci 277 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 278 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 279 END DO 280 END DO; END DO 281 282 IF ( .NOT. l_fast_exchanges ) THEN 283 IF( nimpp >= jpiglo/2+1 ) THEN 284 startloop = 1 285 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 286 startloop = jpiglo/2+1 - nimpp + 1 287 ELSE 288 startloop = nlci + 1 289 ENDIF 290 IF( startloop <= nlci ) THEN 291 DO jl = 1, ipl; DO jk = 1, ipk 292 DO ji = startloop, nlci 293 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 294 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 295 END DO 296 END DO; END DO 297 ENDIF 245 298 ENDIF 246 299 ! … … 251 304 endloop = nlci - 1 252 305 ENDIF 253 DO ji = 1, endloop 254 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 255 ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 256 END DO 306 DO jl = 1, ipl; DO jk = 1, ipk 307 DO ji = 1, endloop 308 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 309 ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 310 END DO 311 END DO; END DO 257 312 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 258 ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-2,:,:,jf) 259 ENDIF 260 ! 261 IF( nimpp + nlci - 1 /= jpiglo ) THEN 262 endloop = nlci 263 ELSE 264 endloop = nlci - 1 265 ENDIF 266 IF( nimpp >= jpiglo/2+1 ) THEN 267 startloop = 1 268 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 269 startloop = jpiglo/2+1 - nimpp + 1 270 ELSE 271 startloop = endloop + 1 272 ENDIF 273 IF( startloop <= endloop ) THEN 274 DO ji = startloop, endloop 275 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 276 ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf) 277 END DO 313 DO jl = 1, ipl; DO jk = 1, ipk 314 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 315 END DO; END DO 316 ENDIF 317 ! 318 IF ( .NOT. l_fast_exchanges ) THEN 319 IF( nimpp + nlci - 1 /= jpiglo ) THEN 320 endloop = nlci 321 ELSE 322 endloop = nlci - 1 323 ENDIF 324 IF( nimpp >= jpiglo/2+1 ) THEN 325 startloop = 1 326 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 327 startloop = jpiglo/2+1 - nimpp + 1 328 ELSE 329 startloop = endloop + 1 330 ENDIF 331 IF( startloop <= endloop ) THEN 332 DO jl = 1, ipl; DO jk = 1, ipk 333 DO ji = startloop, endloop 334 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 335 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 336 END DO 337 END DO; END DO 338 ENDIF 278 339 ENDIF 279 340 ! … … 282 343 CASE DEFAULT ! * closed : the code probably never go through 283 344 ! 284 SELECT CASE ( NAT_IN(jf)) 285 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 286 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 287 ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 288 CASE ( 'F' ) ! F-point 289 ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 290 CASE ( 'I' ) ! ice U-V point 291 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 292 ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 293 END SELECT 345 WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj 294 346 ! 295 347 END SELECT ! npolj … … 301 353 #undef NAT_IN 302 354 #undef SGN_IN 355 #undef J_SIZE 303 356 #undef K_SIZE 304 357 #undef L_SIZE -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbcnfd.F90
r10068 r10175 32 32 INTERFACE lbc_nfd_nogather 33 33 ! ! Currently only 4d array version is needed 34 !MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d35 36 !MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr34 MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 35 MODULE PROCEDURE lbc_nfd_nogather_4d 36 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 37 37 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 38 38 END INTERFACE … … 125 125 ! !== 2D array and array of 2D pointer ==! 126 126 ! 127 !# define DIM_2d128 !# define ROUTINE_NFD lbc_nfd_nogather_2d129 !# include "lbc_nfd_nogather_generic.h90"130 !# undef ROUTINE_NFD131 !# define MULTI132 !# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr133 !# include "lbc_nfd_nogather_generic.h90"134 !# undef ROUTINE_NFD135 !# undef MULTI136 !# undef DIM_2d127 # define DIM_2d 128 # define ROUTINE_NFD lbc_nfd_nogather_2d 129 # include "lbc_nfd_nogather_generic.h90" 130 # undef ROUTINE_NFD 131 # define MULTI 132 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 133 # include "lbc_nfd_nogather_generic.h90" 134 # undef ROUTINE_NFD 135 # undef MULTI 136 # undef DIM_2d 137 137 ! 138 138 ! !== 3D array and array of 3D pointer ==! 139 139 ! 140 !# define DIM_3d141 !# define ROUTINE_NFD lbc_nfd_nogather_3d142 !# include "lbc_nfd_nogather_generic.h90"143 !# undef ROUTINE_NFD144 !# define MULTI145 !# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr146 !# include "lbc_nfd_nogather_generic.h90"147 !# undef ROUTINE_NFD148 !# undef MULTI149 !# undef DIM_3d140 # define DIM_3d 141 # define ROUTINE_NFD lbc_nfd_nogather_3d 142 # include "lbc_nfd_nogather_generic.h90" 143 # undef ROUTINE_NFD 144 # define MULTI 145 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 146 # include "lbc_nfd_nogather_generic.h90" 147 # undef ROUTINE_NFD 148 # undef MULTI 149 # undef DIM_3d 150 150 ! 151 151 ! !== 4D array and array of 4D pointer ==! -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_nfd_generic.h90
r10172 r10175 56 56 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 57 57 INTEGER :: imigr, iihom, ijhom ! local integers 58 INTEGER :: ierr, i taille, ilci, ildi, ilei, iilb58 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 59 59 INTEGER :: ij, iproc 60 60 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather … … 62 62 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 63 ! ! Workspace for message transfers avoiding mpi_allgather 64 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabl, ztabr 64 INTEGER :: ipf_j ! sum of lines for all multi fields 65 INTEGER :: js ! counter 66 INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines 67 INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines 68 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl 69 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr 65 70 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 66 71 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio … … 71 76 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 72 77 ! 73 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 74 ! 75 ALLOCATE( znorthloc(jpimax,4,ipk,ipl,ipf) ) 76 ! 77 znorthloc(:,:,:,:,:) = 0._wp 78 ! 79 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 80 DO jl = 1, ipl 81 DO jk = 1, ipk 82 DO jj = nlcj - ipj +1, nlcj 83 ij = jj - nlcj + ipj 84 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 78 IF( l_north_nogather ) THEN !== ???? ==! 79 80 ALLOCATE(ipj_s(ipf)) 81 82 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 83 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 84 ! by default, only one line is exchanged 85 86 ALLOCATE( jj_s(ipf,2) ) 87 88 ! re-define number of exchanged lines : 89 ! must be two during the first two time steps 90 ! to correct possible incoherent values on North fold lines from restart 91 92 DO jf = 1, ipf 93 IF ( ncom_stp <= nit000 ) ipj_s(jf) = 2 94 ENDDO 95 96 ! Index of modifying lines in input 97 DO jf = 1, ipf ! Loop over the number of arrays to be processed 98 ! 99 SELECT CASE ( npolj ) 100 ! 101 CASE ( 3, 4 ) ! * North fold T-point pivot 102 ! 103 SELECT CASE ( NAT_IN(jf) ) 104 ! 105 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 106 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 107 CASE ( 'V' , 'F' ) ! V-, F-point 108 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 109 END SELECT 110 ! 111 CASE ( 5, 6 ) ! * North fold F-point pivot 112 SELECT CASE ( NAT_IN(jf) ) 113 ! 114 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 115 jj_s(jf,1) = nlcj - 1 116 ipj_s(jf) = 1 ! need only one line anyway 117 CASE ( 'V' , 'F' ) ! V-, F-point 118 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 119 END SELECT 120 ! 121 END SELECT 122 ! 123 ENDDO 124 ! 125 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 126 ! 127 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 128 ! 129 js = 0 130 DO jf = 1, ipf ! Loop over the number of arrays to be processed 131 DO jj = 1, ipj_s(jf) 132 js = js + 1 133 DO jl = 1, ipl 134 DO jk = 1, ipk 135 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 136 END DO 85 137 END DO 86 138 END DO 87 139 END DO 88 END DO 89 ! 90 ! 91 itaille = jpimax * ipj * ipk * ipl * ipf 92 ! 93 IF( l_north_nogather ) THEN !== ???? ==! 94 ALLOCATE( zfoldwk(jpimax,4,ipk,ipl,ipf) ) 95 ALLOCATE( ztabl(jpimax ,4,ipk,ipl,ipf) , ztabr(jpimax*jpmaxngh,4,ipk,ipl,ipf) ) 96 ! 140 ! 141 ibuffsize = jpimax * ipf_j * ipk * ipl 142 ! 143 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 144 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 97 145 ! when some processors of the north fold are suppressed, 98 146 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 99 147 ! and we need a default definition to 0. 100 148 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 101 IF ( jpni*jpnj /= jpnij ) THEN 102 ztabr(:,:,:,:,:) = 0._wp 103 ztabl(:,:,:,:,:) = 0._wp 104 END IF 105 ! 106 DO jf = 1, ipf 107 DO jl = 1, ipl 108 DO jk = 1, ipk 109 DO jj = nlcj-ipj+1, nlcj ! First put local values into the global array 110 ij = jj - nlcj + ipj 111 DO ji = nfsloop, nfeloop 112 ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf) 113 END DO 114 END DO 115 END DO 116 END DO 117 END DO 118 ! 149 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 150 ! 151 ! start waiting time measurement 119 152 IF( ln_timing ) CALL tic_tac(.TRUE.) 120 153 ! 121 154 DO jr = 1, nsndto 122 155 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 123 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )156 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 124 157 ENDIF 125 158 END DO 159 ! 126 160 DO jr = 1,nsndto 127 161 iproc = nfipproc(isendto(jr),jpnj) … … 136 170 ENDIF 137 171 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 138 CALL mpprecv(5, zfoldwk, itaille, iproc) 139 DO jf = 1, ipf 172 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 173 js = 0 174 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 175 js = js + 1 140 176 DO jl = 1, ipl 141 177 DO jk = 1, ipk 142 DO jj = 1, ipj 143 DO ji = ildi, ilei 144 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf) 145 END DO 178 DO ji = ildi, ilei 179 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 146 180 END DO 147 181 END DO 148 182 END DO 149 END DO 183 END DO; END DO 150 184 ELSE IF( iproc == narea-1 ) THEN 151 DO jf = 1, ipf 185 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 152 186 DO jl = 1, ipl 153 187 DO jk = 1, ipk 154 DO jj = 1, ipj 155 DO ji = ildi, ilei 156 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf) 157 END DO 188 DO ji = ildi, ilei 189 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 158 190 END DO 159 191 END DO 160 192 END DO 161 END DO 193 END DO; END DO 162 194 ENDIF 163 195 END DO … … 166 198 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 167 199 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 168 ENDIF 200 ENDIF 169 201 END DO 170 202 ENDIF … … 172 204 IF( ln_timing ) CALL tic_tac(.FALSE.) 173 205 ! 206 ! North fold boundary condition 207 ! 174 208 DO jf = 1, ipf 175 CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 176 END DO 177 DO jf = 1, ipf 209 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 210 END DO 211 ! 212 DEALLOCATE( zfoldwk ) 213 DEALLOCATE( ztabr ) 214 DEALLOCATE( jj_s ) 215 DEALLOCATE( ipj_s ) 216 ELSE !== ???? ==! 217 ! 218 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 219 ! 220 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 221 ! 222 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 178 223 DO jl = 1, ipl 179 224 DO jk = 1, ipk 180 DO jj = nlcj -ipj+1, nlcj ! Scatter back to ARRAY_IN225 DO jj = nlcj - ipj +1, nlcj 181 226 ij = jj - nlcj + ipj 182 DO ji= 1, nlci 183 ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf) 184 END DO 227 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 185 228 END DO 186 229 END DO … … 188 231 END DO 189 232 ! 190 DEALLOCATE( zfoldwk ) 191 DEALLOCATE( ztabl, ztabr ) 192 ELSE !== ???? ==! 193 ALLOCATE( ztab (jpiglo,4,ipk,ipl,ipf ) ) 194 ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) ) 233 ibuffsize = jpimax * ipj * ipk * ipl * ipf 234 ! 235 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 236 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 195 237 ! 196 238 ! when some processors of the north fold are suppressed, … … 198 240 ! and we need a default definition to 0. 199 241 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 200 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:)=0._wp 201 ! 242 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 243 ! 244 ! start waiting time measurement 202 245 IF( ln_timing ) CALL tic_tac(.TRUE.) 203 !204 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &205 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )206 ! 246 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 247 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 248 ! 249 ! stop waiting time measurement 207 250 IF( ln_timing ) CALL tic_tac(.FALSE.) 208 251 !
Note: See TracChangeset
for help on using the changeset viewer.
