Changeset 13286 for NEMO/trunk/src/OCE/LBC
- Timestamp:
- 2020-07-09T17:48:29+02:00 (4 years ago)
- Location:
- NEMO/trunk
- Files:
-
- 13 edited
- 1 copied
-
. (modified) (1 prop)
-
src/OCE/LBC/halo_mng.F90 (copied) (copied from NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/halo_mng.F90)
-
src/OCE/LBC/lbc_lnk_multi_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/lbc_nfd_ext_generic.h90 (modified) (1 diff)
-
src/OCE/LBC/lbc_nfd_generic.h90 (modified) (10 diffs)
-
src/OCE/LBC/lbc_nfd_nogather_generic.h90 (modified) (11 diffs)
-
src/OCE/LBC/lbcnfd.F90 (modified) (1 diff)
-
src/OCE/LBC/lib_mpp.F90 (modified) (2 diffs)
-
src/OCE/LBC/mpp_lbc_north_icb_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/mpp_lnk_generic.h90 (modified) (10 diffs)
-
src/OCE/LBC/mpp_lnk_icb_generic.h90 (modified) (2 diffs)
-
src/OCE/LBC/mpp_loc_generic.h90 (modified) (1 diff)
-
src/OCE/LBC/mpp_nfd_generic.h90 (modified) (2 diffs)
-
src/OCE/LBC/mppini.F90 (modified) (55 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk
- Property svn:externals
-
old new 2 2 ^/utils/build/makenemo@HEAD makenemo 3 3 ^/utils/build/mk@HEAD mk 4 ^/utils/tools /@HEADtools4 ^/utils/tools@HEAD tools 5 5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM … … 8 8 9 9 # SETTE 10 ^/utils/CI/ sette@12931sette10 ^/utils/CI/r12931_sette_ticket2366@HEAD sette
-
- Property svn:externals
-
NEMO/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13226 r13286 39 39 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 40 40 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 41 & , kfillmode, pfillval, lsend, lrecv , ihlcom)41 & , kfillmode, pfillval, lsend, lrecv ) 42 42 !!--------------------------------------------------------------------- 43 43 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine … … 51 51 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 52 52 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 53 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated54 53 !! 55 54 INTEGER :: kfld ! number of elements that will be attributed … … 76 75 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 77 76 ! 78 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv , ihlcom)77 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 79 78 ! 80 79 END SUBROUTINE ROUTINE_MULTI -
NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13226 r13286 34 34 ! 35 35 SELECT CASE ( jpni ) 36 CASE ( 1 ) ; ipj = nlcj! 1 proc only along the i-direction36 CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction 37 37 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction 38 38 END SELECT -
NEMO/trunk/src/OCE/LBC/lbc_nfd_generic.h90
r13226 r13286 10 10 # endif 11 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 12 13 # define K_SIZE(ptab) 1 13 14 # define L_SIZE(ptab) 1 … … 20 21 # endif 21 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 22 24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 25 # define L_SIZE(ptab) 1 … … 30 32 # endif 31 33 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 34 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) 32 35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) … … 40 43 # if defined DIM_2d 41 44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 45 # define J_SIZE(ptab) SIZE(ptab,2) 42 46 # define K_SIZE(ptab) 1 43 47 # define L_SIZE(ptab) 1 … … 45 49 # if defined DIM_3d 46 50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 51 # define J_SIZE(ptab) SIZE(ptab,2) 47 52 # define K_SIZE(ptab) SIZE(ptab,3) 48 53 # define L_SIZE(ptab) 1 … … 50 55 # if defined DIM_4d 51 56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 57 # define J_SIZE(ptab) SIZE(ptab,2) 52 58 # define K_SIZE(ptab) SIZE(ptab,3) 53 59 # define L_SIZE(ptab) SIZE(ptab,4) … … 76 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 77 83 ! 78 INTEGER :: ji, jj, jk, jl, jh,jf ! dummy loop indices79 INTEGER :: ipi, ipj, ipk, ipl,ipf ! dimension of the input array80 INTEGER :: i jt, iju, ipjm184 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: ipj, ipk, ipl, ipf ! dimension of the input array 86 INTEGER :: ii1, ii2, ij1, ij2 81 87 !!---------------------------------------------------------------------- 82 88 ! 83 ipk = K_SIZE(ptab) ! 3rd dimension 89 ipj = J_SIZE(ptab) ! 2nd dimension 90 ipk = K_SIZE(ptab) ! 3rd - 84 91 ipl = L_SIZE(ptab) ! 4th - 85 92 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 86 !87 !88 SELECT CASE ( jpni )89 CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction90 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction91 END SELECT92 ipjm1 = ipj-193 94 93 ! 95 94 DO jf = 1, ipf ! Loop on the number of arrays to be treated … … 101 100 SELECT CASE ( NAT_IN(jf) ) 102 101 CASE ( 'T' , 'W' ) ! T-, W-point 103 DO ji = 2, jpiglo 104 ijt = jpiglo-ji+2 105 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 106 END DO 107 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf) 108 DO ji = jpiglo/2+1, jpiglo 109 ijt = jpiglo-ji+2 110 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 111 END DO 102 DO jl = 1, ipl; DO jk = 1, ipk 103 ! 104 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 105 DO jj = 1, nn_hls 106 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 107 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 108 ! 109 DO ji = 1, nn_hls ! first nn_hls points 110 ii1 = ji ! ends at: nn_hls 111 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 112 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 113 END DO 114 DO ji = 1, 1 ! point nn_hls+1 115 ii1 = nn_hls + ji 116 ii2 = ii1 117 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 118 END DO 119 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 120 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 121 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 122 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 123 END DO 124 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 125 ii1 = jpiglo - nn_hls + ji 126 ii2 = nn_hls + ji 127 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 128 END DO 129 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 130 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 131 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 132 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 133 END DO 134 END DO 135 ! 136 ! line number ipj-nn_hls : right half 137 DO jj = 1, 1 138 ij1 = ipj - nn_hls 139 ij2 = ij1 ! same line 140 ! 141 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 142 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 143 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 144 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 145 END DO 146 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 147 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 148 ii1 = ji ! ends at: nn_hls 149 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 150 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 151 END DO 152 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 153 END DO 154 ! 155 END DO; END DO 112 156 CASE ( 'U' ) ! U-point 113 DO ji = 1, jpiglo-1 114 iju = jpiglo-ji+1 115 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 116 END DO 117 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf) 118 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) 119 DO ji = jpiglo/2, jpiglo-1 120 iju = jpiglo-ji+1 121 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 122 END DO 157 DO jl = 1, ipl; DO jk = 1, ipk 158 ! 159 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 160 DO jj = 1, nn_hls 161 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 162 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 163 ! 164 DO ji = 1, nn_hls ! first nn_hls points 165 ii1 = ji ! ends at: nn_hls 166 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 167 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 168 END DO 169 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 170 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 171 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 172 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 173 END DO 174 DO ji = 1, nn_hls ! last nn_hls points 175 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 176 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 177 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 178 END DO 179 END DO 180 ! 181 ! line number ipj-nn_hls : right half 182 DO jj = 1, 1 183 ij1 = ipj - nn_hls 184 ij2 = ij1 ! same line 185 ! 186 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 187 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 188 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 189 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 190 END DO 191 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 192 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 193 ii1 = ji ! ends at: nn_hls 194 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 195 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 196 END DO 197 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 198 END DO 199 ! 200 END DO; END DO 123 201 CASE ( 'V' ) ! V-point 124 DO ji = 2, jpiglo 125 ijt = jpiglo-ji+2 126 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 127 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf) 128 END DO 129 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf) 202 DO jl = 1, ipl; DO jk = 1, ipk 203 ! 204 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 205 DO jj = 1, nn_hls+1 206 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 207 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 208 ! 209 DO ji = 1, nn_hls ! first nn_hls points 210 ii1 = ji ! ends at: nn_hls 211 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 212 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 213 END DO 214 DO ji = 1, 1 ! point nn_hls+1 215 ii1 = nn_hls + ji 216 ii2 = ii1 217 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 218 END DO 219 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 220 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 221 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 222 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 223 END DO 224 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 225 ii1 = jpiglo - nn_hls + ji 226 ii2 = nn_hls + ji 227 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 228 END DO 229 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 230 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 231 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 232 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 233 END DO 234 END DO 235 ! 236 END DO; END DO 130 237 CASE ( 'F' ) ! F-point 131 DO ji = 1, jpiglo-1 132 iju = jpiglo-ji+1 133 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 134 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf) 135 END DO 136 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf) 137 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) 138 END SELECT 238 DO jl = 1, ipl; DO jk = 1, ipk 239 ! 240 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 241 DO jj = 1, nn_hls+1 242 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 243 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 244 ! 245 DO ji = 1, nn_hls ! first nn_hls points 246 ii1 = ji ! ends at: nn_hls 247 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) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 249 END DO 250 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 251 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 252 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) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 254 END DO 255 DO ji = 1, nn_hls ! last nn_hls points 256 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 257 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) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 259 END DO 260 END DO 261 ! 262 END DO; END DO 263 END SELECT ! NAT_IN(jf) 139 264 ! 140 265 CASE ( 5 , 6 ) ! * North fold F-point pivot … … 142 267 SELECT CASE ( NAT_IN(jf) ) 143 268 CASE ( 'T' , 'W' ) ! T-, W-point 144 DO ji = 1, jpiglo 145 ijt = jpiglo-ji+1 146 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf) 147 END DO 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ! 271 ! first: line number ipj-nn_hls : 3 points 272 DO jj = 1, 1 273 ij1 = ipj - nn_hls 274 ij2 = ij1 ! same line 275 ! 276 DO ji = 1, 1 ! points from jpiglo/2+1 277 ii1 = jpiglo/2 + ji 278 ii2 = jpiglo/2 - ji + 1 279 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 280 END DO 281 DO ji = 1, 1 ! points jpiglo - nn_hls 282 ii1 = jpiglo - nn_hls + ji - 1 283 ii2 = nn_hls + ji 284 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 285 END DO 286 DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done) 287 ! ! as we just changed point jpiglo - nn_hls 288 ii1 = nn_hls + ji - 1 289 ii2 = nn_hls + ji 290 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 291 END DO 292 END DO 293 ! 294 ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full 295 DO jj = 1, nn_hls 296 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 297 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 298 ! 299 DO ji = 1, nn_hls ! first nn_hls points 300 ii1 = ji ! ends at: nn_hls 301 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 302 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 303 END DO 304 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 305 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 306 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 307 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = 1, nn_hls ! last nn_hls points 310 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 311 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 312 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 313 END DO 314 END DO 315 ! 316 END DO; END DO 148 317 CASE ( 'U' ) ! U-point 149 DO ji = 1, jpiglo-1 150 iju = jpiglo-ji 151 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf) 152 END DO 153 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf) 318 DO jl = 1, ipl; DO jk = 1, ipk 319 ! 320 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 321 DO jj = 1, nn_hls 322 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 323 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 324 ! 325 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 326 ii1 = ji ! ends at: nn_hls-1 327 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 328 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 329 END DO 330 DO ji = 1, 1 ! point nn_hls 331 ii1 = nn_hls + ji - 1 332 ii2 = jpiglo - ii1 333 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 334 END DO 335 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 336 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 337 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 338 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 339 END DO 340 DO ji = 1, 1 ! point jpiglo - nn_hls 341 ii1 = jpiglo - nn_hls + ji - 1 342 ii2 = ii1 343 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 344 END DO 345 DO ji = 1, nn_hls ! last nn_hls points 346 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 347 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 348 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 349 END DO 350 END DO 351 ! 352 END DO; END DO 154 353 CASE ( 'V' ) ! V-point 155 DO ji = 1, jpiglo 156 ijt = jpiglo-ji+1 157 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 158 END DO 159 DO ji = jpiglo/2+1, jpiglo 160 ijt = jpiglo-ji+1 161 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 162 END DO 354 DO jl = 1, ipl; DO jk = 1, ipk 355 ! 356 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 357 DO jj = 1, nn_hls 358 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 359 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 360 ! 361 DO ji = 1, nn_hls ! first nn_hls points 362 ii1 = ji ! ends at: nn_hls 363 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 364 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 365 END DO 366 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 367 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 368 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 369 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 370 END DO 371 DO ji = 1, nn_hls ! last nn_hls points 372 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 373 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 374 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 375 END DO 376 END DO 377 ! 378 ! line number ipj-nn_hls : right half 379 DO jj = 1, 1 380 ij1 = ipj - nn_hls 381 ij2 = ij1 ! same line 382 ! 383 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 384 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 385 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 386 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 387 END DO 388 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 389 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 390 ii1 = ji ! ends at: nn_hls 391 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 392 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 393 END DO 394 ! ! last nn_hls points: have been / will done by e-w periodicity 395 END DO 396 ! 397 END DO; END DO 163 398 CASE ( 'F' ) ! F-point 164 DO ji = 1, jpiglo-1 165 iju = jpiglo-ji 166 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 167 END DO 168 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf) 169 DO ji = jpiglo/2+1, jpiglo-1 170 iju = jpiglo-ji 171 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 172 END DO 173 END SELECT 399 DO jl = 1, ipl; DO jk = 1, ipk 400 ! 401 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 402 DO jj = 1, nn_hls 403 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 404 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 405 ! 406 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 407 ii1 = ji ! ends at: nn_hls-1 408 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 409 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 410 END DO 411 DO ji = 1, 1 ! point nn_hls 412 ii1 = nn_hls + ji - 1 413 ii2 = jpiglo - ii1 414 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 415 END DO 416 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 417 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 418 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 419 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 420 END DO 421 DO ji = 1, 1 ! point jpiglo - nn_hls 422 ii1 = jpiglo - nn_hls + ji - 1 423 ii2 = ii1 424 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 425 END DO 426 DO ji = 1, nn_hls ! last nn_hls points 427 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 428 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 429 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 430 END DO 431 END DO 432 ! 433 ! line number ipj-nn_hls : right half 434 DO jj = 1, 1 435 ij1 = ipj - nn_hls 436 ij2 = ij1 ! same line 437 ! 438 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+1 to jpiglo - nn_hls-1 (note: Ni0glo = jpiglo - 2*nn_hls) 439 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 440 ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 441 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 442 END DO 443 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) 444 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1 445 ii1 = ji ! ends at: nn_hls 446 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 447 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 448 END DO 449 ! ! last nn_hls points: have been / will done by e-w periodicity 450 END DO 451 ! 452 END DO; END DO 453 END SELECT ! NAT_IN(jf) 174 454 ! 175 CASE DEFAULT ! * closed : the code probably never go through 176 ! 177 SELECT CASE ( NAT_IN(jf) ) 178 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 179 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 180 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 181 CASE ( 'F' ) ! F-point 182 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 183 END SELECT 184 ! 185 END SELECT ! npolj 455 END SELECT ! npolj 186 456 ! 187 END DO 457 END DO ! ipf 188 458 ! 189 459 END SUBROUTINE ROUTINE_NFD … … 194 464 #undef NAT_IN 195 465 #undef SGN_IN 466 #undef J_SIZE 196 467 #undef K_SIZE 197 468 #undef L_SIZE -
NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13226 r13286 60 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 61 # endif 62 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)63 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 64 # if defined SINGLE_PRECISION 65 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) … … 82 82 !! 83 83 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied85 ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied84 ARRAY_TYPE(:,:,:,:,:) 85 ARRAY2_TYPE(:,:,:,:,:) 86 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 87 87 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 88 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 89 89 ! 90 INTEGER :: ji, jj, jk, 91 INTEGER :: ipi, ipj, ipk, ipl, ipf 92 INTEGER :: ijt, iju, ij pj, ijpjp1, ijta, ijua, jia, startloop, endloop90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf ! dummy loop indices 91 INTEGER :: ipi, ipj, ipk, ipl, ipf, iij, ijj ! dimension of the input array 92 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 93 LOGICAL :: l_fast_exchanges 94 94 !!---------------------------------------------------------------------- … … 100 100 ! Security check for further developments 101 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 102 !103 ijpj = 1 ! index of first modified line104 ijpjp1 = 2 ! index + 1105 106 102 ! 2nd dimension determines exchange speed 107 103 IF (ipj == 1 ) THEN … … 120 116 ! 121 117 CASE ( 'T' , 'W' ) ! T-, W-point 122 IF ( nimpp /= 1 ) THEN ; startloop = 1 123 ELSE ; startloop = 2 124 ENDIF 125 ! 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 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 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 125 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 130 129 END DO 131 130 END DO; END DO 132 131 IF( nimpp == 1 ) THEN 133 132 DO jl = 1, ipl; DO jk = 1, ipk 134 ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 135 END DO; END DO 136 ENDIF 137 ! 138 IF ( .NOT. l_fast_exchanges ) THEN 139 IF( nimpp >= jpiglo/2+1 ) THEN 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 138 END DO 139 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 140 144 startloop = 1 141 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN142 startloop = jpiglo/2+1 - nimpp + 1143 ELSE 144 startloop = nlci + 1145 ENDIF 146 IF( startloop <= nlci ) THEN145 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 147 151 DO jl = 1, ipl; DO jk = 1, ipk 148 DO ji = startloop, nlci149 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 150 154 jia = ji + nimpp - 1 151 155 ijta = jpiglo - jia + 2 152 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 153 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)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) 154 158 ELSE 155 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 156 160 ENDIF 157 161 END DO … … 159 163 ENDIF 160 164 ENDIF 161 162 165 CASE ( 'U' ) ! U-point 163 IF( nimpp + nlci - 1 /= jpiglo ) THEN164 endloop = nlci166 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 endloop = jpi 165 168 ELSE 166 endloop = nlci - 1 167 ENDIF 168 DO jl = 1, ipl; DO jk = 1, ipk 169 DO ji = 1, endloop 170 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 171 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 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 172 178 END DO 173 179 END DO; END DO 174 180 IF (nimpp .eq. 1) THEN 175 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 176 ENDIF 177 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 178 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 179 ENDIF 180 ! 181 IF ( .NOT. l_fast_exchanges ) THEN 182 IF( nimpp + nlci - 1 /= jpiglo ) THEN 183 endloop = nlci 184 ELSE 185 endloop = nlci - 1 186 ENDIF 187 IF( nimpp >= jpiglo/2 ) THEN 188 startloop = 1 189 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 190 startloop = jpiglo/2 - nimpp + 1 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 191 207 ELSE 192 208 startloop = endloop + 1 … … 195 211 DO jl = 1, ipl; DO jk = 1, ipk 196 212 DO ji = startloop, endloop 197 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3198 jia = ji + nimpp - 1 199 ijua = jpiglo - jia + 1 213 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 214 jia = ji + nimpp - 1 215 ijua = jpiglo - jia + 1 200 216 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 201 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf) 202 218 ELSE 203 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 204 220 ENDIF 205 221 END DO … … 210 226 CASE ( 'V' ) ! V-point 211 227 IF( nimpp /= 1 ) THEN 212 startloop = 1 228 startloop = 1 213 229 ELSE 214 startloop = 2 215 ENDIF 216 IF ( .NOT. l_fast_exchanges ) THEN 217 DO jl = 1, ipl; DO jk = 1, ipk 218 DO ji = startloop, nlci 219 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 220 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 221 END DO 222 END DO; END DO 223 ENDIF 224 DO jl = 1, ipl; DO jk = 1, ipk 225 DO ji = startloop, nlci 226 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 227 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 230 startloop = 1 + nn_hls 231 ENDIF 232 IF ( .NOT. l_fast_exchanges ) THEN 233 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 241 END DO; END DO 242 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) 228 247 END DO 229 248 END DO; END DO 230 249 IF (nimpp .eq. 1) THEN 231 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 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 232 256 ENDIF 233 257 CASE ( 'F' ) ! F-point 234 IF( nimpp + nlci - 1 /= jpiglo ) THEN235 endloop = nlci258 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 endloop = jpi 236 260 ELSE 237 endloop = nlci - 1 238 ENDIF 239 IF ( .NOT. l_fast_exchanges ) THEN 240 DO jl = 1, ipl; DO jk = 1, ipk 241 DO ji = 1, endloop 242 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 243 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 244 END DO 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 264 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 245 272 END DO; END DO 246 273 ENDIF 247 274 DO jl = 1, ipl; DO jk = 1, ipk 248 275 DO ji = 1, endloop 249 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 250 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 251 END DO 252 END DO; END DO 253 IF (nimpp .eq. 1) THEN 254 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 255 IF ( .NOT. l_fast_exchanges ) & 256 ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 257 ENDIF 258 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 259 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 260 IF ( .NOT. l_fast_exchanges ) & 261 ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 262 ENDIF 263 ! 264 END SELECT 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 265 308 ! 266 309 CASE ( 5, 6 ) ! * North fold F-point pivot … … 269 312 CASE ( 'T' , 'W' ) ! T-, W-point 270 313 DO jl = 1, ipl; DO jk = 1, ipk 271 DO ji = 1, nlci 272 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 273 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 274 END DO 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 275 321 END DO; END DO 276 322 ! 277 323 CASE ( 'U' ) ! U-point 278 IF( nimpp + nlci - 1 /= jpiglo ) THEN279 endloop = nlci324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 280 326 ELSE 281 endloop = nlci - 1 282 ENDIF 283 DO jl = 1, ipl; DO jk = 1, ipk 284 DO ji = 1, endloop 285 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 286 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 287 END DO 288 END DO; END DO 289 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 290 DO jl = 1, ipl; DO jk = 1, ipk 291 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 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 292 347 END DO; END DO 293 348 ENDIF … … 295 350 CASE ( 'V' ) ! V-point 296 351 DO jl = 1, ipl; DO jk = 1, ipk 297 DO ji = 1, nlci 298 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 299 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 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 300 358 END DO 301 359 END DO; END DO 302 360 303 361 IF ( .NOT. l_fast_exchanges ) THEN 304 IF( nimpp >= jpiglo/2+1) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN 305 363 startloop = 1 306 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN307 startloop = jpiglo/2+1 - nimpp + 1308 ELSE 309 startloop = nlci + 1310 ENDIF 311 IF( startloop <= nlci ) THEN312 DO jl = 1, ipl; DO jk = 1, ipk 313 DO ji = startloop, nlci314 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3315 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)316 END DO364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 365 startloop = Ni0glo/2+2 - nimpp + nn_hls 366 ELSE 367 startloop = jpi + 1 368 ENDIF 369 IF( startloop <= jpi ) THEN 370 DO jl = 1, ipl; DO jk = 1, ipk 371 DO ji = startloop, jpi 372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 374 END DO 317 375 END DO; END DO 318 376 ENDIF … … 320 378 ! 321 379 CASE ( 'F' ) ! F-point 322 IF( nimpp + nlci - 1 /= jpiglo ) THEN323 endloop = nlci380 IF( nimpp + jpi - 1 /= jpiglo ) THEN 381 endloop = jpi 324 382 ELSE 325 endloop = nlci - 1 326 ENDIF 327 DO jl = 1, ipl; DO jk = 1, ipk 328 DO ji = 1, endloop 329 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 330 ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 331 END DO 332 END DO; END DO 333 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 334 DO jl = 1, ipl; DO jk = 1, ipk 335 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 336 END DO; END DO 337 ENDIF 338 ! 339 IF ( .NOT. l_fast_exchanges ) THEN 340 IF( nimpp + nlci - 1 /= jpiglo ) THEN 341 endloop = nlci 342 ELSE 343 endloop = nlci - 1 344 ENDIF 345 IF( nimpp >= jpiglo/2+1 ) THEN 346 startloop = 1 347 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 348 startloop = jpiglo/2+1 - nimpp + 1 383 endloop = jpi - nn_hls 384 ENDIF 385 DO jl = 1, ipl; DO jk = 1, ipk 386 DO jj = 1, nn_hls 387 ijj = jpj -jj +1 388 DO ji = 1, endloop 389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 391 END DO 392 END DO 393 END DO; END DO 394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 395 DO jl = 1, ipl; DO jk = 1, ipk 396 DO jj = 1, nn_hls 397 ijj = jpj -jj +1 398 DO ii = 1, nn_hls 399 iij = jpi -ii+1 400 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 DO 402 END DO 403 END DO; END DO 404 ENDIF 405 ! 406 IF ( .NOT. l_fast_exchanges ) THEN 407 IF( nimpp + jpi - 1 /= jpiglo ) THEN 408 endloop = jpi 409 ELSE 410 endloop = jpi - nn_hls 411 ENDIF 412 IF( nimpp >= Ni0glo/2+2 ) THEN 413 startloop = 1 414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 415 startloop = Ni0glo/2+2 - nimpp + nn_hls 349 416 ELSE 350 417 startloop = endloop + 1 … … 353 420 DO jl = 1, ipl; DO jk = 1, ipk 354 421 DO ji = startloop, endloop 355 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2356 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 357 424 END DO 358 425 END DO; END DO -
NEMO/trunk/src/OCE/LBC/lbcnfd.F90
r13226 r13286 70 70 71 71 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: 72 INTEGER, PUBLIC :: nsndto , nfsloop, nfeloop!:72 INTEGER, PUBLIC :: nsndto !: 73 73 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate 74 INTEGER, PUBLIC :: ijpj 74 75 75 76 !!---------------------------------------------------------------------- -
NEMO/trunk/src/OCE/LBC/lib_mpp.F90
r13226 r13286 1098 1098 ! Look for how many procs on the northern boundary 1099 1099 ndim_rank_north = 0 1100 DO jjproc = 1, jpni j1101 IF( n jmppt(jjproc) == njmppmax) ndim_rank_north = ndim_rank_north + 11100 DO jjproc = 1, jpni 1101 IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 1102 1102 END DO 1103 1103 ! … … 1109 1109 ! Note : the rank start at 0 in MPI 1110 1110 ii = 0 1111 DO ji = 1, jpni j1112 IF ( n jmppt(ji) == njmppmax) THEN1111 DO ji = 1, jpni 1112 IF ( nfproc(ji) /= -1 ) THEN 1113 1113 ii=ii+1 1114 nrank_north(ii)= ji-11114 nrank_north(ii)=nfproc(ji) 1115 1115 END IF 1116 1116 END DO -
NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13226 r13286 36 36 ! 37 37 INTEGER :: ji, jj, jr 38 INTEGER :: ierr, itaille , ildi, ilei, iilb39 INTEGER :: ipj, ij, iproc 38 INTEGER :: ierr, itaille 39 INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp 40 40 ! 41 41 REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e … … 47 47 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 48 48 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 49 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj, jpni) )49 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) 50 50 ! 51 51 # if defined SINGLE_PRECISION … … 73 73 IF( ln_timing ) CALL tic_tac(.FALSE.) 74 74 ! 75 ijnr = 0 75 76 DO jr = 1, ndim_rank_north ! recover the global north array 76 iproc = nrank_north(jr) + 1 77 ildi = nldit (iproc) 78 ilei = nleit (iproc) 79 iilb = nimppt(iproc) 80 DO jj = 1-kextj, ipj+kextj 81 DO ji = ildi, ilei 82 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 77 iproc = nfproc(jr) 78 IF( iproc /= -1 ) THEN 79 impp = nfimpp(jr) 80 ipi = nfjpi(jr) 81 ijnr = ijnr + 1 82 DO jj = 1-kextj, ipj+kextj 83 DO ji = 1, ipi 84 ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc 85 ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) 86 END DO 83 87 END DO 84 END DO88 ENDIF 85 89 END DO 86 90 -
NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90
r13226 r13286 72 72 73 73 #if defined MULTI 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv , ihlcom)74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 75 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 76 76 #else 77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv , ihlcom)77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv ) 78 78 #endif 79 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 84 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated87 86 ! 88 87 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 92 91 INTEGER :: ierr 93 92 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 94 INTEGER :: ihl ! number of ranks and rows to be communicated 95 REAL(PRECISION) :: zland 93 REAL(wp) :: zland 96 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 97 95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos … … 109 107 ipl = L_SIZE(ptab) ! 4th - 110 108 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 111 !112 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom113 ELSE ; ihl = 1114 END IF115 109 ! 116 110 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) … … 175 169 ! 176 170 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 177 isize = ihl* jpj * ipk * ipl * ipf171 isize = nn_hls * jpj * ipk * ipl * ipf 178 172 ! 179 173 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 180 IF( llsend_we ) ALLOCATE( zsnd_we( ihl,jpj,ipk,ipl,ipf) )181 IF( llsend_ea ) ALLOCATE( zsnd_ea( ihl,jpj,ipk,ipl,ipf) )182 IF( llrecv_we ) ALLOCATE( zrcv_we( ihl,jpj,ipk,ipl,ipf) )183 IF( llrecv_ea ) ALLOCATE( zrcv_ea( ihl,jpj,ipk,ipl,ipf) )174 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 175 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 176 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 177 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 184 178 ! 185 179 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 186 ishift = ihl187 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl188 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl180 ishift = nn_hls 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 182 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 189 183 END DO ; END DO ; END DO ; END DO ; END DO 190 184 ENDIF 191 185 ! 192 186 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 193 ishift = jpi - 2 * ihl194 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl195 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2* ihl + 1 -> jpi - ihl187 ishift = jpi - 2 * nn_hls 188 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 189 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 196 190 END DO ; END DO ; END DO ; END DO ; END DO 197 191 ENDIF … … 215 209 ! 2.1 fill weastern halo 216 210 ! ---------------------- 217 ! ishift = 0 ! fill halo from ji = 1 to ihl211 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 218 212 SELECT CASE ( ifill_we ) 219 213 CASE ( jpfillnothing ) ! no filling 220 214 CASE ( jpfillmpi ) ! use data received by MPI 221 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl222 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl223 END DO ; END DO ; END DO ; END DO ; END DO215 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 216 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 217 END DO ; END DO ; END DO ; END DO ; END DO 224 218 CASE ( jpfillperio ) ! use east-weast periodicity 225 ishift2 = jpi - 2 * ihl226 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl219 ishift2 = jpi - 2 * nn_hls 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 227 221 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 228 END DO ; END DO ; END DO ; END DO ; END DO222 END DO ; END DO ; END DO ; END DO ; END DO 229 223 CASE ( jpfillcopy ) ! filling with inner domain values 230 DO jf = 1, ipf ! number of arrays to be treated 231 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 232 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 233 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 234 END DO ; END DO ; END DO ; END DO 235 ENDIF 236 END DO 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 226 END DO ; END DO ; END DO ; END DO ; END DO 237 227 CASE ( jpfillcst ) ! filling with constant value 238 DO jf = 1, ipf ! number of arrays to be treated 239 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 240 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 241 ARRAY_IN(ji,jj,jk,jl,jf) = zland 242 END DO; END DO ; END DO ; END DO 243 ENDIF 244 END DO 228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 229 ARRAY_IN(ji,jj,jk,jl,jf) = zland 230 END DO ; END DO ; END DO ; END DO ; END DO 245 231 END SELECT 246 232 ! 247 233 ! 2.2 fill eastern halo 248 234 ! --------------------- 249 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi235 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 250 236 SELECT CASE ( ifill_ea ) 251 237 CASE ( jpfillnothing ) ! no filling 252 238 CASE ( jpfillmpi ) ! use data received by MPI 253 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl254 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl+ 1 -> jpi239 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 240 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 255 241 END DO ; END DO ; END DO ; END DO ; END DO 256 242 CASE ( jpfillperio ) ! use east-weast periodicity 257 ishift2 = ihl258 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl243 ishift2 = nn_hls 244 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 259 245 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 260 246 END DO ; END DO ; END DO ; END DO ; END DO 261 247 CASE ( jpfillcopy ) ! filling with inner domain values 262 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 263 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 264 250 END DO ; END DO ; END DO ; END DO ; END DO 265 251 CASE ( jpfillcst ) ! filling with constant value 266 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 267 253 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 268 END DO ; END DO ; END DO ; END DO ; END DO254 END DO ; END DO ; END DO ; END DO ; END DO 269 255 END SELECT 270 256 ! … … 278 264 ! 279 265 SELECT CASE ( jpni ) 280 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp281 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.266 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 267 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 282 268 END SELECT 283 269 ! … … 290 276 ! ---------------------------------------------------- ! 291 277 ! 292 IF( llsend_so ) ALLOCATE( zsnd_so(jpi, ihl,ipk,ipl,ipf) )293 IF( llsend_no ) ALLOCATE( zsnd_no(jpi, ihl,ipk,ipl,ipf) )294 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi, ihl,ipk,ipl,ipf) )295 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi, ihl,ipk,ipl,ipf) )296 ! 297 isize = jpi * ihl* ipk * ipl * ipf278 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 279 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 280 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 281 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 282 ! 283 isize = jpi * nn_hls * ipk * ipl * ipf 298 284 299 285 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 300 286 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 301 ishift = ihl302 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi303 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl287 ishift = nn_hls 288 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 289 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 304 290 END DO ; END DO ; END DO ; END DO ; END DO 305 291 ENDIF 306 292 ! 307 293 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 308 ishift = jpj - 2 * ihl309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi310 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2* ihl+1 -> jpj-ihl294 ishift = jpj - 2 * nn_hls 295 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 311 297 END DO ; END DO ; END DO ; END DO ; END DO 312 298 ENDIF … … 329 315 ! 5.1 fill southern halo 330 316 ! ---------------------- 331 ! ishift = 0 ! fill halo from jj = 1 to ihl317 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 332 318 SELECT CASE ( ifill_so ) 333 319 CASE ( jpfillnothing ) ! no filling 334 320 CASE ( jpfillmpi ) ! use data received by MPI 335 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi336 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl337 END DO ; END DO ; END DO ; END DO ; END DO321 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 322 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 323 END DO ; END DO ; END DO ; END DO ; END DO 338 324 CASE ( jpfillperio ) ! use north-south periodicity 339 ishift2 = jpj - 2 * ihl340 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi325 ishift2 = jpj - 2 * nn_hls 326 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 341 327 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 342 END DO ; END DO ; END DO ; END DO ; END DO328 END DO ; END DO ; END DO ; END DO ; END DO 343 329 CASE ( jpfillcopy ) ! filling with inner domain values 344 DO jf = 1, ipf ! number of arrays to be treated 345 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 346 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 347 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 348 END DO ; END DO ; END DO ; END DO 349 ENDIF 350 END DO 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 332 END DO ; END DO ; END DO ; END DO ; END DO 351 333 CASE ( jpfillcst ) ! filling with constant value 352 DO jf = 1, ipf ! number of arrays to be treated 353 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 354 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 355 ARRAY_IN(ji,jj,jk,jl,jf) = zland 356 END DO; END DO ; END DO ; END DO 357 ENDIF 358 END DO 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 335 ARRAY_IN(ji,jj,jk,jl,jf) = zland 336 END DO ; END DO ; END DO ; END DO ; END DO 359 337 END SELECT 360 338 ! 361 339 ! 5.2 fill northern halo 362 340 ! ---------------------- 363 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj341 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 364 342 SELECT CASE ( ifill_no ) 365 343 CASE ( jpfillnothing ) ! no filling 366 344 CASE ( jpfillmpi ) ! use data received by MPI 367 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi368 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj- ihl+1 -> jpj345 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 346 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 369 347 END DO ; END DO ; END DO ; END DO ; END DO 370 348 CASE ( jpfillperio ) ! use north-south periodicity 371 ishift2 = ihl372 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi349 ishift2 = nn_hls 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 373 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 374 END DO ; END DO ; END DO ; END DO ; END DO352 END DO ; END DO ; END DO ; END DO ; END DO 375 353 CASE ( jpfillcopy ) ! filling with inner domain values 376 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 377 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 378 END DO ; END DO ; END DO ; END DO ; END DO356 END DO ; END DO ; END DO ; END DO ; END DO 379 357 CASE ( jpfillcst ) ! filling with constant value 380 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 381 359 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 382 END DO ; END DO ; END DO ; END DO ; END DO360 END DO ; END DO ; END DO ; END DO ; END DO 383 361 END SELECT 384 362 ! … … 410 388 ! 411 389 END SUBROUTINE ROUTINE_LNK 412 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 413 393 #undef ARRAY_TYPE 414 394 #undef NAT_IN -
NEMO/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13226 r13286 105 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 107 iihom = jpi -nreci-kexti107 iihom = jpi - (2 * nn_hls) -kexti 108 108 DO jl = 1, ipreci 109 109 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) … … 165 165 ! 166 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 167 ijhom = jpj -nrecj-kextj167 ijhom = jpj - (2 * nn_hls) - kextj 168 168 DO jl = 1, iprecj 169 169 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) -
NEMO/trunk/src/OCE/LBC/mpp_loc_generic.h90
r13226 r13286 109 109 #undef PRECISION 110 110 #undef ARRAY_TYPE 111 #undef MA X_TYPE111 #undef MASK_TYPE 112 112 #undef ARRAY_IN 113 113 #undef MASK_IN -
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r13226 r13286 74 74 # endif 75 75 76 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kf ld )76 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 77 77 !!---------------------------------------------------------------------- 78 78 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 79 79 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 80 80 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 81 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 82 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 81 83 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 82 84 ! 85 LOGICAL :: ll_add_line 83 86 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 84 INTEGER :: ipi, ipj, ip k, ipl, ipf! dimension of the input array87 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 85 88 INTEGER :: imigr, iihom, ijhom ! local integers 86 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 87 INTEGER :: ij, iproc 89 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 90 INTEGER :: ii1, ii2, ij1, ij2 91 INTEGER :: ipimax, i0max 92 INTEGER :: ij, iproc, ipni, ijnr 88 93 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 89 94 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 90 95 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 91 96 ! ! Workspace for message transfers avoiding mpi_allgather 92 INTEGER :: ip f_j! sum of lines for all multi fields93 INTEGER :: js ! counter94 INTEGER , DIMENSION(:,:),ALLOCATABLE :: jj_s ! position of sent lines95 INTEGER , DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sentlines96 REAL(PRECISION), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl97 REAL(PRECISION), DIMENSION(:,:,:,: ,:) , ALLOCATABLE :: ztab, ztabr98 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: z northloc, zfoldwk99 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo io97 INTEGER :: ipj_b ! sum of lines for all multi fields 98 INTEGER :: i012 ! 0, 1 or 2 99 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 100 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 101 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 102 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 103 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc 104 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 100 105 !!---------------------------------------------------------------------- 101 106 ! … … 106 111 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 107 112 108 ALLOCATE(ipj_s(ipf)) 109 110 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 111 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 112 ! by default, only one line is exchanged 113 114 ALLOCATE( jj_s(ipf,2) ) 115 116 ! re-define number of exchanged lines : 117 ! must be two during the first two time steps 118 ! to correct possible incoherent values on North fold lines from restart 119 113 ! --- define number of exchanged lines --- 114 ! 115 ! In theory we should exchange only nn_hls lines. 116 ! 117 ! However, some other points are duplicated in the north pole folding: 118 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 119 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 120 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 121 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 122 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 123 ! - jperio=[56], grid=U : no points are duplicated 124 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 125 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 126 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 127 ! This explain why these duplicated points may have different values even if they are at the exact same location. 128 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 129 ! This is slightly slower but necessary to avoid different values on identical grid points!! 130 ! 120 131 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 121 132 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 122 133 !!!!!!!!! I don't know why we must do that... !!!!!!!! 123 134 l_full_nf_update = .TRUE. 124 125 ! Two lines update (slower but necessary to avoid different values ion identical grid points 126 IF ( l_full_nf_update .OR. & ! if coupling fields 127 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 128 ipj_s(:) = 2 135 ! also force it if not restart during the first 2 steps (leap frog?) 136 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 137 138 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 139 IF( ll_add_line ) THEN 140 DO jf = 1, ipf ! Loop over the number of arrays to be processed 141 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 142 END DO 143 ELSE 144 ipj_s(:) = nn_hls 145 ENDIF 146 147 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 148 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 149 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 129 150 130 151 ! Index of modifying lines in input 152 ij1 = 0 131 153 DO jf = 1, ipf ! Loop over the number of arrays to be processed 132 154 ! 133 155 SELECT CASE ( npolj ) 134 !135 156 CASE ( 3, 4 ) ! * North fold T-point pivot 136 !137 157 SELECT CASE ( NAT_IN(jf) ) 138 ! 139 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 140 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 141 CASE ( 'V' , 'F' ) ! V-, F-point 142 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 158 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 159 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 143 160 END SELECT 144 ! 145 CASE ( 5, 6 ) ! * North fold F-point pivot 161 CASE ( 5, 6 ) ! * North fold F-point pivot 146 162 SELECT CASE ( NAT_IN(jf) ) 147 ! 148 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 149 jj_s(jf,1) = nlcj - 1 150 ipj_s(jf) = 1 ! need only one line anyway 151 CASE ( 'V' , 'F' ) ! V-, F-point 152 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 163 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 164 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 153 165 END SELECT 154 !155 166 END SELECT 156 ! 157 ENDDO 158 ! 159 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 160 ! 161 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 162 ! 163 js = 0 164 DO jf = 1, ipf ! Loop over the number of arrays to be processed 167 ! 165 168 DO jj = 1, ipj_s(jf) 166 js = js + 1 167 DO jl = 1, ipl 168 DO jk = 1, ipk 169 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 170 END DO 171 END DO 169 ij1 = ij1 + 1 170 jj_b(jj,jf) = ij1 171 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 172 172 END DO 173 ! 173 174 END DO 174 175 ! 175 ibuffsize = jpimax * ipf_j * ipk * ipl 176 ! 177 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 178 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 179 ! when some processors of the north fold are suppressed, 180 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 181 ! and we need a default definition to 0. 182 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 183 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 176 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 177 ibuffsize = jpimax * ipj_b * ipk * ipl 178 ! 179 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 180 DO jj = 1, ipj_s(jf) 181 ij1 = jj_b(jj,jf) 182 ij2 = jj_s(jj,jf) 183 DO ji = 1, jpi 184 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 185 END DO 186 DO ji = jpi+1, jpimax 187 ztabb(ji,ij1,jk,jl) = HUGE(0._wp) ! avoid sending uninitialized values (make sure we don't use it) 188 END DO 189 END DO 190 END DO ; END DO ; END DO 184 191 ! 185 192 ! start waiting time measurement 186 193 IF( ln_timing ) CALL tic_tac(.TRUE.) 187 194 ! 195 ! send the data as soon as possible 188 196 DO jr = 1, nsndto 189 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 190 CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 197 iproc = nfproc(isendto(jr)) 198 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 199 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 191 200 ENDIF 192 201 END DO 193 202 ! 203 ipimax = jpimax * jpmaxngh 204 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 205 ! 206 DO jr = 1, nsndto 207 ! 208 ipni = isendto(jr) 209 iproc = nfproc(ipni) 210 ipi = nfjpi (ipni) 211 ! 212 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 213 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 214 ENDIF 215 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 216 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain 217 ENDIF 218 impp = nfimpp(ipni) - nfimpp(isendto(1)) 219 ! 220 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 221 ! 222 SELECT CASE ( kfillmode ) 223 CASE ( jpfillnothing ) ! no filling 224 CASE ( jpfillcopy ) ! filling with inner domain values 225 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 226 DO jj = 1, ipj_s(jf) 227 ij1 = jj_b(jj,jf) 228 ij2 = jj_s(jj,jf) 229 DO ji = iis0, iie0 230 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 231 END DO 232 END DO 233 END DO ; END DO ; END DO 234 CASE ( jpfillcst ) ! filling with constant value 235 DO jl = 1, ipl ; DO jk = 1, ipk 236 DO jj = 1, ipj_b 237 DO ji = iis0, iie0 238 ztabr(impp+ji,jj,jk,jl) = pfillval 239 END DO 240 END DO 241 END DO ; END DO 242 END SELECT 243 ! 244 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 245 ! 246 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 247 DO jj = 1, ipj_s(jf) 248 ij1 = jj_b(jj,jf) 249 ij2 = jj_s(jj,jf) 250 DO ji = iis0, iie0 251 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 252 END DO 253 END DO 254 END DO ; END DO ; END DO 255 ! 256 ELSE ! get data from a neighbour trough communication 257 ! 258 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 259 DO jl = 1, ipl ; DO jk = 1, ipk 260 DO jj = 1, ipj_b 261 DO ji = iis0, iie0 262 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 263 END DO 264 END DO 265 END DO ; END DO 266 267 ENDIF 268 ! 269 END DO ! nsndto 270 ! 271 IF( ln_timing ) CALL tic_tac(.FALSE.) 272 ! 273 ! North fold boundary condition 274 ! 275 DO jf = 1, ipf 276 ij1 = jj_b( 1 ,jf) 277 ij2 = jj_b(ipj_s(jf),jf) 278 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 279 END DO 280 ! 281 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 282 ! 194 283 DO jr = 1,nsndto 195 iproc = nfipproc(isendto(jr),jpnj) 196 IF(iproc /= -1) THEN 197 iilb = nimppt(iproc+1) 198 ilci = nlcit (iproc+1) 199 ildi = nldit (iproc+1) 200 ilei = nleit (iproc+1) 201 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 202 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 203 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 204 ENDIF 284 iproc = nfproc(isendto(jr)) 205 285 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 206 CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 207 js = 0 208 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 209 js = js + 1 210 DO jl = 1, ipl 211 DO jk = 1, ipk 212 DO ji = ildi, ilei 213 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 214 END DO 215 END DO 216 END DO 217 END DO; END DO 218 ELSE IF( iproc == narea-1 ) THEN 219 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 220 DO jl = 1, ipl 221 DO jk = 1, ipk 222 DO ji = ildi, ilei 223 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 224 END DO 225 END DO 226 END DO 227 END DO; END DO 286 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 228 287 ENDIF 229 288 END DO 230 DO jr = 1,nsndto 231 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 232 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 233 ENDIF 234 END DO 235 ! 236 IF( ln_timing ) CALL tic_tac(.FALSE.) 237 ! 238 ! North fold boundary condition 239 ! 240 DO jf = 1, ipf 241 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 242 END DO 243 ! 244 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 289 DEALLOCATE( ztabb ) 245 290 ! 246 291 ELSE !== allgather exchanges ==! 247 292 ! 248 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 249 ! 250 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 251 ! 252 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jj = nlcj - ipj +1, nlcj 256 ij = jj - nlcj + ipj 257 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 258 END DO 293 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 294 ipj = nn_hls + 2 295 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 296 ipj2 = 2 * nn_hls + 2 297 ! 298 i0max = jpimax - 2 * nn_hls 299 ibuffsize = i0max * ipj * ipk * ipl * ipf 300 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 301 ! 302 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab 303 DO jj = 1, ipj 304 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 305 DO ji = 1, Ni_0 306 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 307 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = Ni_0+1, i0max 310 znorthloc(ji,jj,jk,jl,jf) = HUGE(0._wp) ! avoid sending uninitialized values (make sure we don't use it) 259 311 END DO 260 312 END DO 261 END DO 262 ! 263 ibuffsize = jpimax * ipj * ipk * ipl * ipf 264 ! 265 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 266 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 267 ! 268 ! when some processors of the north fold are suppressed, 269 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 270 ! and we need a default definition to 0. 271 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 272 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 313 END DO ; END DO ; END DO 273 314 ! 274 315 ! start waiting time measurement 275 316 IF( ln_timing ) CALL tic_tac(.TRUE.) 276 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_TYPE, & 277 & znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 278 ! 317 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 279 318 ! stop waiting time measurement 280 319 IF( ln_timing ) CALL tic_tac(.FALSE.) 281 ! 282 DO jr = 1, ndim_rank_north ! recover the global north array 283 iproc = nrank_north(jr) + 1 284 iilb = nimppt(iproc) 285 ilci = nlcit (iproc) 286 ildi = nldit (iproc) 287 ilei = nleit (iproc) 288 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 289 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 290 DO jf = 1, ipf 291 DO jl = 1, ipl 292 DO jk = 1, ipk 320 DEALLOCATE( znorthloc ) 321 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 322 ! 323 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 324 ijnr = 0 325 DO jr = 1, jpni ! recover the global north array 326 iproc = nfproc(jr) 327 impp = nfimpp(jr) 328 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 329 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 330 ! 331 SELECT CASE ( kfillmode ) 332 CASE ( jpfillnothing ) ! no filling 333 CASE ( jpfillcopy ) ! filling with inner domain values 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 293 335 DO jj = 1, ipj 294 DO ji = ildi, ilei 295 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 336 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 337 DO ji = 1, ipi 338 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 339 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 296 340 END DO 297 341 END DO 342 END DO ; END DO ; END DO 343 CASE ( jpfillcst ) ! filling with constant value 344 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 345 DO jj = 1, ipj 346 DO ji = 1, ipi 347 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 348 ztabglo(ii1,jj,jk,jl,jf) = pfillval 349 END DO 350 END DO 351 END DO ; END DO ; END DO 352 END SELECT 353 ! 354 ELSE 355 ijnr = ijnr + 1 356 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 357 DO jj = 1, ipj 358 DO ji = 1, ipi 359 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 360 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 361 END DO 298 362 END DO 363 END DO ; END DO ; END DO 364 ENDIF 365 ! 366 END DO ! jpni 367 DEALLOCATE( znorthglo ) 368 ! 369 DO jf = 1, ipf 370 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 371 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 372 DO jj = 1, nn_hls + 1 373 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 374 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 375 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 376 END DO 377 END DO ; END DO 378 END DO 379 ! 380 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 381 DO jj = 1, nn_hls + 1 382 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 383 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 384 DO ji= 1, jpi 385 ii2 = mig(ji) 386 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 299 387 END DO 300 388 END DO 301 END DO 302 DO jf = 1, ipf 303 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 304 END DO 305 ! 306 DO jf = 1, ipf 307 DO jl = 1, ipl 308 DO jk = 1, ipk 309 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 310 ij = jj - nlcj + ipj 311 DO ji= 1, nlci 312 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 313 END DO 314 END DO 315 END DO 316 END DO 317 END DO 318 ! 319 ! 320 DEALLOCATE( ztab ) 321 DEALLOCATE( znorthgloio ) 322 ENDIF 323 ! 324 DEALLOCATE( znorthloc ) 389 END DO ; END DO ; END DO 390 ! 391 DEALLOCATE( ztabglo ) 392 ! 393 ENDIF ! l_north_nogather 325 394 ! 326 395 END SUBROUTINE ROUTINE_NFD -
NEMO/trunk/src/OCE/LBC/mppini.F90
r13216 r13286 8 8 !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 9 9 !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom 11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication 12 12 !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file 13 13 !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 … … 15 15 16 16 !!---------------------------------------------------------------------- 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_ioipsl : IOIPSL initialization in mpp 20 !! mpp_init_partition: Calculate MPP domain decomposition 21 !! factorise : Calculate the factors of the no. of MPI processes 22 !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! init_ioipsl: IOIPSL initialization in mpp 19 !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging 20 !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute 23 21 !!---------------------------------------------------------------------- 24 22 USE dom_oce ! ocean space and time domain 25 23 USE bdy_oce ! open BounDarY 26 24 ! 27 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 28 26 USE lib_mpp ! distribued memory computing library 29 27 USE iom ! nemo I/O library … … 34 32 PRIVATE 35 33 36 PUBLIC mpp_init ! called by opa.F90 37 38 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 39 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 34 PUBLIC mpp_init ! called by nemogcm.F90 35 PUBLIC mpp_getnum ! called by prtctl 36 PUBLIC mpp_basesplit ! called by prtctl 37 PUBLIC mpp_is_ocean ! called by prtctl 38 39 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 40 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 40 41 41 42 !!---------------------------------------------------------------------- … … 61 62 !!---------------------------------------------------------------------- 62 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 63 66 jpimax = jpiglo 64 67 jpjmax = jpjglo … … 66 69 jpj = jpjglo 67 70 jpk = jpkglo 68 jpim1 = jpi-1 ! inner domain indices 69 jpjm1 = jpj-1 ! " " 70 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpim1 = jpi-1 ! inner domain indices 72 jpjm1 = jpj-1 ! " " 73 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 ! 75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 76 ! 71 77 jpij = jpi*jpj 72 78 jpni = 1 73 79 jpnj = 1 74 80 jpnij = jpni*jpnj 75 nimpp = 1 ! 81 nn_hls = 1 82 nimpp = 1 76 83 njmpp = 1 77 nlci = jpi78 nlcj = jpj79 nldi = 180 nldj = 181 nlei = jpi82 nlej = jpj83 84 nbondi = 2 84 85 nbondj = 2 … … 135 136 !! njmpp : latitudinal index 136 137 !! narea : number for local area 137 !! nlci : first dimension138 !! nlcj : second dimension139 138 !! nbondi : mark for "east-west local boundary" 140 139 !! nbondj : mark for "north-south local boundary" … … 147 146 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 148 147 INTEGER :: inijmin 149 INTEGER :: i2add150 148 INTEGER :: inum ! local logical unit 151 INTEGER :: idir, ifreq , icont! local integers149 INTEGER :: idir, ifreq ! local integers 152 150 INTEGER :: ii, il1, ili, imil ! - - 153 151 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 162 160 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 163 161 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 164 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace165 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -166 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -167 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -162 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 163 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 164 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 165 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 168 166 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 169 167 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & … … 173 171 & cn_ice, nn_ice_dta, & 174 172 & ln_vol, nn_volctl, nn_rimwidth 175 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly173 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 176 174 !!---------------------------------------------------------------------- 177 175 ! … … 186 184 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 187 185 ! 186 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 188 187 IF(lwp) THEN 189 188 WRITE(numout,*) ' Namelist nammpp' … … 195 194 ENDIF 196 195 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 196 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 197 197 ENDIF 198 198 ! 199 199 IF(lwm) WRITE( numond, nammpp ) 200 200 ! 201 !!!------------------------------------ 202 !!! nn_hls shloud be read in nammpp 203 !!!------------------------------------ 204 jpiglo = Ni0glo + 2 * nn_hls 205 jpjglo = Nj0glo + 2 * nn_hls 206 ! 201 207 ! do we need to take into account bdy_msk? 202 208 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) … … 208 214 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 209 215 ! 210 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core216 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 211 217 ! 212 218 ! 1. Dimension arrays for subdomains 213 219 ! ----------------------------------- 214 220 ! 215 ! If dimensions of processor grid weren't specified in the namelist file221 ! If dimensions of processors grid weren't specified in the namelist file 216 222 ! then we calculate them here now that we have our communicator size 217 223 IF(lwp) THEN … … 221 227 ENDIF 222 228 IF( jpni < 1 .OR. jpnj < 1 ) THEN 223 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes229 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 224 230 llauto = .TRUE. 225 231 llbest = .TRUE. 226 232 ELSE 227 233 llauto = .FALSE. 228 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes234 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 229 235 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 230 CALL mpp_bas ic_decomposition(jpni, jpnj, jpimax, jpjmax )231 ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition232 CALL mpp_bas ic_decomposition(inbi, inbj, iimax, ijmax )236 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 237 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 238 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 233 239 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 234 240 IF(lwp) THEN … … 261 267 ! look for land mpi subdomains... 262 268 ALLOCATE( llisoce(jpni,jpnj) ) 263 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )269 CALL mpp_is_ocean( llisoce ) 264 270 inijmin = COUNT( llisoce ) ! number of oce subdomains 265 271 … … 270 276 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 271 277 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 272 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core278 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 273 279 ENDIF 274 280 … … 294 300 WRITE(numout,*) 295 301 ENDIF 296 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core302 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 297 303 ENDIF 298 304 … … 319 325 9003 FORMAT (a, i5) 320 326 321 IF( numbot /= -1 ) CALL iom_close( numbot ) 322 IF( numbdy /= -1 ) CALL iom_close( numbdy ) 323 324 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 325 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 326 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 327 & nleit(jpnij) , nlejt(jpnij) , & 327 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 328 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 329 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 330 & nie0all(jpnij) , nje0all(jpnij) , & 328 331 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 329 332 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 330 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &331 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &332 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &333 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &333 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 334 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 335 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 336 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 334 337 & STAT=ierr ) 335 338 CALL mpp_sum( 'mppini', ierr ) … … 345 348 ! ----------------------------------- 346 349 ! 347 nreci = 2 * nn_hls 348 nrecj = 2 * nn_hls 349 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 350 nfiimpp(:,:) = iimppt(:,:) 351 nfilcit(:,:) = ilci(:,:) 350 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 351 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 352 ! 353 !DO jn = 1, jpni 354 ! jproc = ipproc(jn,jpnj) 355 ! ii = iin(jproc+1) 356 ! ij = ijn(jproc+1) 357 ! nfproc(jn) = jproc 358 ! nfimpp(jn) = iimppt(ii,ij) 359 ! nfjpi (jn) = ijpi(ii,ij) 360 !END DO 361 nfproc(:) = ipproc(:,jpnj) 362 nfimpp(:) = iimppt(:,jpnj) 363 nfjpi (:) = ijpi(:,jpnj) 352 364 ! 353 365 IF(lwp) THEN … … 358 370 WRITE(numout,*) ' jpni = ', jpni 359 371 WRITE(numout,*) ' jpnj = ', jpnj 372 WRITE(numout,*) ' jpnij = ', jpnij 360 373 WRITE(numout,*) 361 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo362 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo374 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 375 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 363 376 ENDIF 364 377 … … 375 388 ii = 1 + MOD(iarea0,jpni) 376 389 ij = 1 + iarea0/jpni 377 ili = i lci(ii,ij)378 ilj = i lcj(ii,ij)390 ili = ijpi(ii,ij) 391 ilj = ijpj(ii,ij) 379 392 ibondi(ii,ij) = 0 ! default: has e-w neighbours 380 393 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 391 404 ioea(ii,ij) = iarea0 + 1 392 405 iono(ii,ij) = iarea0 + jpni 393 i ldi(ii,ij) = 1 + nn_hls394 i lei(ii,ij) = ili - nn_hls395 i ldj(ii,ij) = 1 + nn_hls396 i lej(ii,ij) = ilj - nn_hls406 iis0(ii,ij) = 1 + nn_hls 407 iie0(ii,ij) = ili - nn_hls 408 ijs0(ii,ij) = 1 + nn_hls 409 ije0(ii,ij) = ilj - nn_hls 397 410 398 411 ! East-West periodicity: change ibondi, ioea, iowe … … 432 445 ! ---------------------------- 433 446 ! 434 ! specify which subdomains are oce subdomains; other are land subdomains435 ipproc(:,:) = -1436 icont = -1437 DO jarea = 1, jpni*jpnj438 iarea0 = jarea - 1439 ii = 1 + MOD(iarea0,jpni)440 ij = 1 + iarea0/jpni441 IF( llisoce(ii,ij) ) THEN442 icont = icont + 1443 ipproc(ii,ij) = icont444 iin(icont+1) = ii445 ijn(icont+1) = ij446 ENDIF447 END DO448 ! if needed add some land subdomains to reach jpnij active subdomains449 i2add = jpnij - inijmin450 DO jarea = 1, jpni*jpnj451 iarea0 = jarea - 1452 ii = 1 + MOD(iarea0,jpni)453 ij = 1 + iarea0/jpni454 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN455 icont = icont + 1456 ipproc(ii,ij) = icont457 iin(icont+1) = ii458 ijn(icont+1) = ij459 i2add = i2add - 1460 ENDIF461 END DO462 nfipproc(:,:) = ipproc(:,:)463 464 447 ! neighbour treatment: change ibondi, ibondj if next to a land zone 465 448 DO jarea = 1, jpni*jpnj … … 500 483 ENDIF 501 484 END DO 502 503 ! Update il[de][ij] according to modified ibond[ij]504 ! ----------------------505 DO jproc = 1, jpnij506 ii = iin(jproc)507 ij = ijn(jproc)508 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1509 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)510 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1511 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)512 END DO513 485 514 486 ! 5. Subdomain print … … 523 495 DO jj = jpnj, 1, -1 524 496 WRITE(numout,9403) (' ',ji=il1,il2-1) 525 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)497 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 526 498 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 527 499 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 580 552 noea = ii_noea(narea) 581 553 nono = ii_nono(narea) 582 nlci = ilci(ii,ij)583 nldi = ildi(ii,ij)584 nlei = ilei(ii,ij)585 nlcj = ilcj(ii,ij)586 nldj = ildj(ii,ij)587 nlej = ilej(ii,ij)554 jpi = ijpi(ii,ij) 555 !!$ Nis0 = iis0(ii,ij) 556 !!$ Nie0 = iie0(ii,ij) 557 jpj = ijpj(ii,ij) 558 !!$ Njs0 = ijs0(ii,ij) 559 !!$ Nje0 = ije0(ii,ij) 588 560 nbondi = ibondi(ii,ij) 589 561 nbondj = ibondj(ii,ij) 590 562 nimpp = iimppt(ii,ij) 591 563 njmpp = ijmppt(ii,ij) 592 jpi = nlci 593 jpj = nlcj 594 jpk = jpkglo ! third dim 595 #if defined key_agrif 596 ! simple trick to use same vertical grid as parent but different number of levels: 597 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 598 ! Suppress once vertical online interpolation is ok 599 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 600 #endif 601 jpim1 = jpi-1 ! inner domain indices 602 jpjm1 = jpj-1 ! " " 603 jpkm1 = MAX( 1, jpk-1 ) ! " " 604 jpij = jpi*jpj ! jpi x j 564 jpk = jpkglo ! third dim 565 ! 566 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 567 ! 568 jpim1 = jpi-1 ! inner domain indices 569 jpjm1 = jpj-1 ! " " 570 jpkm1 = MAX( 1, jpk-1 ) ! " " 571 jpij = jpi*jpj ! jpi x j 605 572 DO jproc = 1, jpnij 606 573 ii = iin(jproc) 607 574 ij = ijn(jproc) 608 nlcit(jproc) = ilci(ii,ij)609 n ldit(jproc) = ildi(ii,ij)610 n leit(jproc) = ilei(ii,ij)611 nlcjt(jproc) = ilcj(ii,ij)612 n ldjt(jproc) = ildj(ii,ij)613 n lejt(jproc) = ilej(ii,ij)575 jpiall (jproc) = ijpi(ii,ij) 576 nis0all(jproc) = iis0(ii,ij) 577 nie0all(jproc) = iie0(ii,ij) 578 jpjall (jproc) = ijpj(ii,ij) 579 njs0all(jproc) = ijs0(ii,ij) 580 nje0all(jproc) = ije0(ii,ij) 614 581 ibonit(jproc) = ibondi(ii,ij) 615 582 ibonjt(jproc) = ibondj(ii,ij) … … 625 592 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 626 593 & ' ( local: ',narea,jpi,jpj,' )' 627 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '594 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 628 595 629 596 DO jproc = 1, jpnij 630 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &631 & n ldit (jproc), nldjt(jproc), &632 & n leit (jproc), nlejt(jproc), &597 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 598 & nis0all(jproc), njs0all(jproc), & 599 & nie0all(jproc), nje0all(jproc), & 633 600 & nimppt (jproc), njmppt (jproc), & 634 601 & ii_nono(jproc), ii_noso(jproc), & … … 664 631 WRITE(numout,*) ' l_Iperio = ', l_Iperio 665 632 WRITE(numout,*) ' l_Jperio = ', l_Jperio 666 WRITE(numout,*) ' nlci = ', nlci667 WRITE(numout,*) ' nlcj = ', nlcj668 633 WRITE(numout,*) ' nimpp = ', nimpp 669 634 WRITE(numout,*) ' njmpp = ', njmpp 670 WRITE(numout,*) ' nreci = ', nreci671 WRITE(numout,*) ' nrecj = ', nrecj672 WRITE(numout,*) ' nn_hls = ', nn_hls673 635 ENDIF 674 636 … … 692 654 ENDIF 693 655 ! 694 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)656 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 695 657 ! 696 658 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 697 CALL mpp_init_nfdcom ! northfold neighbour lists659 CALL init_nfdcom ! northfold neighbour lists 698 660 IF (llwrtlay) THEN 699 661 WRITE(inum,*) 700 662 WRITE(inum,*) 701 663 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 702 WRITE(inum,*) 'nfsloop : ', nfsloop703 WRITE(inum,*) 'nfeloop : ', nfeloop704 664 WRITE(inum,*) 'nsndto : ', nsndto 705 665 WRITE(inum,*) 'isendto : ', isendto … … 711 671 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 712 672 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 713 & i lci, ilcj, ilei, ilej, ildi, ildj, &673 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 714 674 & iono, ioea, ioso, iowe, llisoce) 715 675 ! … … 717 677 718 678 719 SUBROUTINE mpp_bas ic_decomposition(knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)720 !!---------------------------------------------------------------------- 721 !! *** ROUTINE mpp_bas ic_decomposition***679 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 680 !!---------------------------------------------------------------------- 681 !! *** ROUTINE mpp_basesplit *** 722 682 !! 723 683 !! ** Purpose : Lay out the global domain over processors. … … 731 691 !! klcj : second dimension 732 692 !!---------------------------------------------------------------------- 693 INTEGER, INTENT(in ) :: kiglo, kjglo 694 INTEGER, INTENT(in ) :: khls 733 695 INTEGER, INTENT(in ) :: knbi, knbj 734 696 INTEGER, INTENT( out) :: kimax, kjmax … … 737 699 ! 738 700 INTEGER :: ji, jj 701 INTEGER :: i2hls 739 702 INTEGER :: iresti, irestj, irm, ijpjmin 740 INTEGER :: ireci, irecj741 !!----------------------------------------------------------------------703 !!---------------------------------------------------------------------- 704 i2hls = 2*khls 742 705 ! 743 706 #if defined key_nemocice_decomp 744 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.745 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.707 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 708 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 746 709 #else 747 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.748 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.710 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 711 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 749 712 #endif 750 713 IF( .NOT. PRESENT(kimppt) ) RETURN … … 753 716 ! ----------------------------------- 754 717 ! Computation of local domain sizes klci() klcj() 755 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo718 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 756 719 ! The subdomains are squares lesser than or equal to the global 757 720 ! dimensions divided by the number of processors minus the overlap array. 758 721 ! 759 ireci = 2 * nn_hls 760 irecj = 2 * nn_hls 761 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 762 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 722 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 723 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 763 724 ! 764 725 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 765 726 #if defined key_nemocice_decomp 766 727 ! Change padding to be consistent with CICE 767 klci(1:knbi-1 ,:) = kimax768 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)769 klcj(: ,1:knbj-1) = kjmax770 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)728 klci(1:knbi-1,: ) = kimax 729 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 730 klcj(: ,1:knbj-1) = kjmax 731 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 771 732 #else 772 733 klci(1:iresti ,:) = kimax 773 734 klci(iresti+1:knbi ,:) = kimax-1 774 IF( MINVAL(klci) < 3) THEN775 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'735 IF( MINVAL(klci) < 2*i2hls ) THEN 736 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 776 737 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 777 738 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 779 740 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 780 741 ! minimize the size of the last row to compensate for the north pole folding coast 781 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 782 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 783 irm = knbj - irestj ! total number of lines to be removed 784 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 785 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 786 irestj = knbj - 1 - irm 787 klcj(:, 1:irestj) = kjmax 742 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 743 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 744 irm = knbj - irestj ! total number of lines to be removed 745 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 746 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 747 irestj = knbj - 1 - irm 788 748 klcj(:, irestj+1:knbj-1) = kjmax-1 789 749 ELSE 790 ijpjmin = 3 791 klcj(:, 1:irestj) = kjmax 792 klcj(:, irestj+1:knbj) = kjmax-1 793 ENDIF 794 IF( MINVAL(klcj) < ijpjmin ) THEN 795 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 750 klcj(:, irestj+1:knbj ) = kjmax-1 751 ENDIF 752 klcj(:,1:irestj) = kjmax 753 IF( MINVAL(klcj) < 2*i2hls ) THEN 754 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 796 755 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 797 756 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 807 766 DO jj = 1, knbj 808 767 DO ji = 2, knbi 809 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci768 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 810 769 END DO 811 770 END DO … … 815 774 DO jj = 2, knbj 816 775 DO ji = 1, knbi 817 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj776 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 818 777 END DO 819 778 END DO 820 779 ENDIF 821 780 822 END SUBROUTINE mpp_bas ic_decomposition823 824 825 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )826 !!---------------------------------------------------------------------- 827 !! *** ROUTINE mpp_init_bestpartition ***781 END SUBROUTINE mpp_basesplit 782 783 784 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 785 !!---------------------------------------------------------------------- 786 !! *** ROUTINE bestpartition *** 828 787 !! 829 788 !! ** Purpose : … … 867 826 inbimax = 0 868 827 inbjmax = 0 869 isziref = jpiglo*jpjglo+1870 iszjref = jpiglo*jpjglo+1828 isziref = Ni0glo*Nj0glo+1 829 iszjref = Ni0glo*Nj0glo+1 871 830 ! 872 831 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 876 835 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 877 836 #else 878 iszitst = ( jpiglo - 2*nn_hls+ (ji-1) ) / ji + 2*nn_hls837 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls 879 838 #endif 880 839 IF( iszitst < isziref ) THEN … … 887 846 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 888 847 #else 889 iszjtst = ( jpjglo - 2*nn_hls+ (ji-1) ) / ji + 2*nn_hls848 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls 890 849 #endif 891 850 IF( iszjtst < iszjref ) THEN … … 927 886 iszij1(:) = iszi1(:) * iszj1(:) 928 887 929 ! if ther ris no land and no print888 ! if there is no land and no print 930 889 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 931 890 ! get the smaller partition which gives the smallest subdomain size … … 942 901 isz0 = 0 ! number of best partitions 943 902 inbij = 1 ! start with the min value of inbij1 => 1 944 iszij = jpiglo*jpjglo+1 ! default: larger than global domain903 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain 945 904 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 946 905 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results … … 975 934 ji = isz0 ! initialization with the largest value 976 935 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 977 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)936 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 978 937 inbijold = COUNT(llisoce) 979 938 DEALLOCATE( llisoce ) 980 939 DO ji =isz0-1,1,-1 981 940 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 982 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)941 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 983 942 inbij = COUNT(llisoce) 984 943 DEALLOCATE( llisoce ) … … 1006 965 ii = ii -1 1007 966 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 1008 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core967 CALL mpp_is_ocean( llisoce ) ! must be done by all core 1009 968 inbij = COUNT(llisoce) 1010 969 DEALLOCATE( llisoce ) … … 1015 974 DEALLOCATE( inbi0, inbj0 ) 1016 975 ! 1017 END SUBROUTINE mpp_init_bestpartition976 END SUBROUTINE bestpartition 1018 977 1019 978 … … 1024 983 !! ** Purpose : the the proportion of land points in the surface land-sea mask 1025 984 !! 1026 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask985 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 1027 986 !!---------------------------------------------------------------------- 1028 987 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 1041 1000 1042 1001 ! number of processes reading the bathymetry file 1043 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1002 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 1044 1003 1045 1004 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 1051 1010 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 1052 1011 ! 1053 ijsz = jpjglo / iproc ! width of the stripe to read1054 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 11055 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading1056 ! 1057 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1058 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1012 ijsz = Nj0glo / iproc ! width of the stripe to read 1013 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1014 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1015 ! 1016 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1017 CALL readbot_strip( ijstr, ijsz, lloce ) 1059 1018 inboce = COUNT(lloce) ! number of ocean point in the stripe 1060 1019 DEALLOCATE(lloce) … … 1065 1024 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1066 1025 ! 1067 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1026 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1068 1027 ! 1069 1028 END SUBROUTINE mpp_init_landprop 1070 1029 1071 1030 1072 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1073 !!---------------------------------------------------------------------- 1074 !! *** ROUTINE mpp_init_nboce *** 1075 !! 1076 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1077 !! subdomains contain at least 1 ocean point 1078 !! 1079 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1080 !!---------------------------------------------------------------------- 1081 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1082 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1083 ! 1084 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1085 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1031 SUBROUTINE mpp_is_ocean( ldisoce ) 1032 !!---------------------------------------------------------------------- 1033 !! *** ROUTINE mpp_is_ocean *** 1034 !! 1035 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1036 !! subdomains, including 1 halo (even if nn_hls>1), contain 1037 !! at least 1 ocean point. 1038 !! We must indeed ensure that each subdomain that is a neighbour 1039 !! of a land subdomain as only land points on its boundary 1040 !! (inside the inner subdomain) with the land subdomain. 1041 !! This is needed to get the proper bondary conditions on 1042 !! a subdomain with a closed boundary. 1043 !! 1044 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1045 !!---------------------------------------------------------------------- 1046 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1047 ! 1086 1048 INTEGER :: idiv, iimax, ijmax, iarea 1049 INTEGER :: inbi, inbj, inx, iny, inry, isty 1087 1050 INTEGER :: ji, jn 1088 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1090 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1051 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1052 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1053 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1054 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1055 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1091 1056 !!---------------------------------------------------------------------- 1092 1057 ! do nothing if there is no land-sea mask … … 1095 1060 RETURN 1096 1061 ENDIF 1097 1098 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1099 IF ( knbj == 1 ) THEN ; idiv = mppsize 1100 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1101 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1102 ENDIF 1062 ! 1063 inbi = SIZE( ldisoce, dim = 1 ) 1064 inbj = SIZE( ldisoce, dim = 2 ) 1065 ! 1066 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1067 IF ( inbj == 1 ) THEN ; idiv = mppsize 1068 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1069 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1070 ENDIF 1071 ! 1072 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1103 1073 inboce(:,:) = 0 ! default no ocean point found 1104 1105 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1106 ! 1107 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1108 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11074 ! 1075 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1076 ! 1077 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1078 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1109 1079 ! 1110 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1111 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1080 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1081 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1112 1082 ! 1113 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1114 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1115 DO ji = 1, knbi 1116 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1083 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1084 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1085 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1086 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1087 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1088 ! 1089 IF( iarea == 1 ) THEN ! the first line was not read 1090 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1091 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1092 ELSE 1093 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1094 ENDIF 1095 ENDIF 1096 IF( iarea == inbj ) THEN ! the last line was not read 1097 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1098 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1099 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1100 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1101 DO ji = 3,inx-1 1102 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1103 END DO 1104 DO ji = inx/2+2,inx-1 1105 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1106 END DO 1107 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1108 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1109 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1110 DO ji = 2,inx-1 1111 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1112 END DO 1113 ELSE ! closed boundary 1114 lloce(2:inx-1,iny) = .FALSE. 1115 ENDIF 1116 ENDIF 1117 ! ! first and last column were not read 1118 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1119 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1120 ELSE 1121 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1122 ENDIF 1123 ! 1124 DO ji = 1, inbi 1125 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1117 1126 END DO 1118 1127 ! 1119 1128 DEALLOCATE(lloce) 1120 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1129 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1121 1130 ! 1122 1131 ENDIF 1123 1132 END DO 1124 1133 1125 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1134 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1126 1135 CALL mpp_sum( 'mppini', inboce_1d ) 1127 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1136 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1128 1137 ldisoce(:,:) = inboce(:,:) /= 0 1129 ! 1130 END SUBROUTINE mpp_init_isoce 1138 DEALLOCATE(inboce, inboce_1d) 1139 ! 1140 END SUBROUTINE mpp_is_ocean 1131 1141 1132 1142 1133 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1134 !!---------------------------------------------------------------------- 1135 !! *** ROUTINE mpp_init_readbot_strip ***1143 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1144 !!---------------------------------------------------------------------- 1145 !! *** ROUTINE readbot_strip *** 1136 1146 !! 1137 1147 !! ** Purpose : Read relevant bathymetric information in order to … … 1139 1149 !! of land domains, in an mpp computation. 1140 1150 !! 1141 !! ** Method : read stipe of size ( jpiglo,...)1142 !!---------------------------------------------------------------------- 1143 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1144 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1145 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1151 !! ** Method : read stipe of size (Ni0glo,...) 1152 !!---------------------------------------------------------------------- 1153 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1154 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1155 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1146 1156 ! 1147 1157 INTEGER :: inumsave ! local logical unit 1148 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot, zbdy1158 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1149 1159 !!---------------------------------------------------------------------- 1150 1160 ! 1151 1161 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1152 1162 ! 1153 IF( numbot /= -1 ) THEN 1154 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1163 IF( numbot /= -1 ) THEN 1164 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1155 1165 ELSE 1156 zbot(:,:) = 1. 1157 ENDIF 1158 1159 IF( numbdy /= -1 ) THEN! Adjust with bdy_msk if it exists1160 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )1166 zbot(:,:) = 1._wp ! put a non-null value 1167 ENDIF 1168 ! 1169 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1170 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1161 1171 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1162 1172 ENDIF 1163 1173 ! 1164 ldoce(:,:) = zbot(:,:) > 0. 1174 ldoce(:,:) = zbot(:,:) > 0._wp 1165 1175 numout = inumsave 1166 1176 ! 1167 END SUBROUTINE mpp_init_readbot_strip 1168 1169 1170 SUBROUTINE mpp_init_ioipsl 1171 !!---------------------------------------------------------------------- 1172 !! *** ROUTINE mpp_init_ioipsl *** 1177 END SUBROUTINE readbot_strip 1178 1179 1180 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1181 !!---------------------------------------------------------------------- 1182 !! *** ROUTINE mpp_getnum *** 1183 !! 1184 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1185 !! 1186 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1187 !!---------------------------------------------------------------------- 1188 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1189 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1190 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1191 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1192 ! 1193 INTEGER :: ii, ij, jarea, iarea0 1194 INTEGER :: icont, i2add , ini, inj, inij 1195 !!---------------------------------------------------------------------- 1196 ! 1197 ini = SIZE(ldisoce, dim = 1) 1198 inj = SIZE(ldisoce, dim = 2) 1199 inij = SIZE(kipos) 1200 ! 1201 ! specify which subdomains are oce subdomains; other are land subdomains 1202 kproc(:,:) = -1 1203 icont = -1 1204 DO jarea = 1, ini*inj 1205 iarea0 = jarea - 1 1206 ii = 1 + MOD(iarea0,ini) 1207 ij = 1 + iarea0/ini 1208 IF( ldisoce(ii,ij) ) THEN 1209 icont = icont + 1 1210 kproc(ii,ij) = icont 1211 kipos(icont+1) = ii 1212 kjpos(icont+1) = ij 1213 ENDIF 1214 END DO 1215 ! if needed add some land subdomains to reach inij active subdomains 1216 i2add = inij - COUNT( ldisoce ) 1217 DO jarea = 1, ini*inj 1218 iarea0 = jarea - 1 1219 ii = 1 + MOD(iarea0,ini) 1220 ij = 1 + iarea0/ini 1221 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1222 icont = icont + 1 1223 kproc(ii,ij) = icont 1224 kipos(icont+1) = ii 1225 kjpos(icont+1) = ij 1226 i2add = i2add - 1 1227 ENDIF 1228 END DO 1229 ! 1230 END SUBROUTINE mpp_getnum 1231 1232 1233 SUBROUTINE init_ioipsl 1234 !!---------------------------------------------------------------------- 1235 !! *** ROUTINE init_ioipsl *** 1173 1236 !! 1174 1237 !! ** Purpose : … … 1187 1250 ! Set idompar values equivalent to the jpdom_local_noextra definition 1188 1251 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1189 iglo(1) = jpiglo 1190 iglo(2) = jpjglo 1191 iloc(1) = nlci 1192 iloc(2) = nlcj 1193 iabsf(1) = nimppt(narea) 1194 iabsf(2) = njmppt(narea) 1252 iglo( :) = (/ Ni0glo, Nj0glo /) 1253 iloc( :) = (/ Ni_0 , Nj_0 /) 1254 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1195 1255 iabsl(:) = iabsf(:) + iloc(:) - 1 1196 ihals(1) = nldi - 1 1197 ihals(2) = nldj - 1 1198 ihale(1) = nlci - nlei 1199 ihale(2) = nlcj - nlej 1200 idid(1) = 1 1201 idid(2) = 2 1256 ihals(:) = (/ 0 , 0 /) 1257 ihale(:) = (/ 0 , 0 /) 1258 idid( :) = (/ 1 , 2 /) 1202 1259 1203 1260 IF(lwp) THEN 1204 1261 WRITE(numout,*) 1205 WRITE(numout,*) 'mpp _init_ioipsl : iloc = ', iloc (1), iloc (2)1206 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf (1), iabsf(2)1207 WRITE(numout,*) ' ihals = ', ihals (1), ihals(2)1208 WRITE(numout,*) ' ihale = ', ihale (1), ihale(2)1262 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1263 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1264 WRITE(numout,*) ' ihals = ', ihals 1265 WRITE(numout,*) ' ihale = ', ihale 1209 1266 ENDIF 1210 1267 ! 1211 1268 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1212 1269 ! 1213 END SUBROUTINE mpp_init_ioipsl1214 1215 1216 SUBROUTINE mpp_init_nfdcom1217 !!---------------------------------------------------------------------- 1218 !! *** ROUTINE mpp_init_nfdcom ***1270 END SUBROUTINE init_ioipsl 1271 1272 1273 SUBROUTINE init_nfdcom 1274 !!---------------------------------------------------------------------- 1275 !! *** ROUTINE init_nfdcom *** 1219 1276 !! ** Purpose : Setup for north fold exchanges with explicit 1220 1277 !! point-to-point messaging … … 1226 1283 !!---------------------------------------------------------------------- 1227 1284 INTEGER :: sxM, dxM, sxT, dxT, jn 1228 INTEGER :: njmppmax 1229 !!---------------------------------------------------------------------- 1230 ! 1231 njmppmax = MAXVAL( njmppt ) 1285 !!---------------------------------------------------------------------- 1232 1286 ! 1233 1287 !initializes the north-fold communication variables … … 1235 1289 nsndto = 0 1236 1290 ! 1237 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1291 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1238 1292 ! 1239 1293 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1240 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11294 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1241 1295 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1242 1296 dxM = jpiglo - nimppt(narea) + 2 … … 1247 1301 DO jn = 1, jpni 1248 1302 ! 1249 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1250 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1303 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1304 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1251 1305 ! 1252 1306 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1262 1316 ! 1263 1317 END DO 1264 nfsloop = 11265 nfeloop = nlci1266 DO jn = 2,jpni-11267 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1268 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1269 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1270 ENDIF1271 END DO1272 1318 ! 1273 1319 ENDIF 1274 1320 l_north_nogather = .TRUE. 1275 1321 ! 1276 END SUBROUTINE mpp_init_nfdcom 1277 1322 END SUBROUTINE init_nfdcom 1278 1323 1279 1324 #endif 1280 1325 1326 SUBROUTINE init_doloop 1327 !!---------------------------------------------------------------------- 1328 !! *** ROUTINE init_doloop *** 1329 !! 1330 !! ** Purpose : set the starting/ending indices of DO-loop 1331 !! These indices are used in do_loop_substitute.h90 1332 !!---------------------------------------------------------------------- 1333 ! 1334 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1335 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1336 ! 1337 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1338 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1339 ! 1340 IF( nn_hls == 1 ) THEN !* halo size of 1 1341 ! 1342 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1343 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1344 ! 1345 ELSE !* larger halo size... 1346 ! 1347 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1348 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1349 ! 1350 ENDIF 1351 ! 1352 Ni_0 = Nie0 - Nis0 + 1 1353 Nj_0 = Nje0 - Njs0 + 1 1354 Ni_1 = Nie1 - Nis1 + 1 1355 Nj_1 = Nje1 - Njs1 + 1 1356 Ni_2 = Nie2 - Nis2 + 1 1357 Nj_2 = Nje2 - Njs2 + 1 1358 ! 1359 END SUBROUTINE init_doloop 1360 1281 1361 !!====================================================================== 1282 1362 END MODULE mppini
Note: See TracChangeset
for help on using the changeset viewer.
