[14644] | 1 | |
---|
| 2 | SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn, khls ) |
---|
[8586] | 3 | !!---------------------------------------------------------------------- |
---|
| 4 | !! |
---|
| 5 | !! ** Purpose : lateral boundary condition : North fold treatment |
---|
| 6 | !! without allgather exchanges. |
---|
| 7 | !! |
---|
| 8 | !!---------------------------------------------------------------------- |
---|
[14644] | 9 | REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab ! |
---|
| 10 | REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab2 ! |
---|
| 11 | CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of array grid-points |
---|
| 12 | REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary |
---|
| 13 | INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls |
---|
[8586] | 14 | ! |
---|
[14644] | 15 | INTEGER :: ji, jj, jk, jn, jl, jh ! dummy loop indices |
---|
| 16 | INTEGER :: ipk, ipl, ii, iij, ijj ! dimension of the input array |
---|
[13286] | 17 | INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop |
---|
[10425] | 18 | LOGICAL :: l_fast_exchanges |
---|
[8586] | 19 | !!---------------------------------------------------------------------- |
---|
[14644] | 20 | ipk = SIZE(ptab,3) |
---|
| 21 | ipl = SIZE(ptab,4) |
---|
[8586] | 22 | ! |
---|
[10425] | 23 | ! 2nd dimension determines exchange speed |
---|
[14644] | 24 | l_fast_exchanges = SIZE(ptab2,2) == 1 |
---|
[8586] | 25 | ! |
---|
[14644] | 26 | IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot |
---|
[9190] | 27 | ! |
---|
[14644] | 28 | SELECT CASE ( cd_nat ) |
---|
[8586] | 29 | ! |
---|
[14644] | 30 | CASE ( 'T' , 'W' ) ! T-, W-point |
---|
| 31 | IF ( nimpp /= 1 ) THEN ; startloop = 1 |
---|
| 32 | ELSE ; startloop = 1 + khls |
---|
| 33 | ENDIF |
---|
[9190] | 34 | ! |
---|
[14644] | 35 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 36 | DO jj = 1, khls |
---|
| 37 | ijj = jpj -jj +1 |
---|
| 38 | DO ji = startloop, jpi |
---|
| 39 | ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 |
---|
| 40 | ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) |
---|
| 41 | END DO |
---|
| 42 | END DO |
---|
| 43 | END DO; END DO |
---|
| 44 | IF( nimpp == 1 ) THEN |
---|
[10425] | 45 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 46 | DO jj = 1, khls |
---|
| 47 | ijj = jpj -jj +1 |
---|
| 48 | DO ii = 0, khls-1 |
---|
| 49 | ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,jk,jl) |
---|
[13286] | 50 | END DO |
---|
[10425] | 51 | END DO |
---|
| 52 | END DO; END DO |
---|
[14644] | 53 | ENDIF |
---|
| 54 | ! |
---|
| 55 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
| 56 | IF( nimpp >= Ni0glo/2+2 ) THEN |
---|
| 57 | startloop = 1 |
---|
| 58 | ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN |
---|
| 59 | startloop = Ni0glo/2+2 - nimpp + khls |
---|
| 60 | ELSE |
---|
| 61 | startloop = jpi + 1 |
---|
| 62 | ENDIF |
---|
| 63 | IF( startloop <= jpi ) THEN |
---|
[10425] | 64 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 65 | DO ji = startloop, jpi |
---|
| 66 | ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 |
---|
| 67 | jia = ji + nimpp - 1 |
---|
| 68 | ijta = jpiglo - jia + 2 |
---|
| 69 | IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN |
---|
| 70 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijta-nimpp+khls,jpj-khls,jk,jl) |
---|
| 71 | ELSE |
---|
| 72 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) |
---|
| 73 | ENDIF |
---|
[13286] | 74 | END DO |
---|
[10425] | 75 | END DO; END DO |
---|
[8586] | 76 | ENDIF |
---|
[14644] | 77 | ENDIF |
---|
| 78 | CASE ( 'U' ) ! U-point |
---|
| 79 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 80 | endloop = jpi |
---|
| 81 | ELSE |
---|
| 82 | endloop = jpi - khls |
---|
| 83 | ENDIF |
---|
| 84 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 85 | DO jj = 1, khls |
---|
| 86 | ijj = jpj -jj +1 |
---|
| 87 | DO ji = 1, endloop |
---|
| 88 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 89 | ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) |
---|
| 90 | END DO |
---|
| 91 | END DO |
---|
| 92 | END DO; END DO |
---|
| 93 | IF (nimpp .eq. 1) THEN |
---|
| 94 | DO jj = 1, khls |
---|
| 95 | ijj = jpj -jj +1 |
---|
| 96 | DO ii = 0, khls-1 |
---|
| 97 | ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) |
---|
| 98 | END DO |
---|
| 99 | END DO |
---|
| 100 | ENDIF |
---|
| 101 | IF((nimpp + jpi - 1) .eq. jpiglo) THEN |
---|
| 102 | DO jj = 1, khls |
---|
| 103 | ijj = jpj -jj +1 |
---|
| 104 | DO ii = 1, khls |
---|
| 105 | ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) |
---|
| 106 | END DO |
---|
| 107 | END DO |
---|
| 108 | ENDIF |
---|
| 109 | ! |
---|
| 110 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
[13286] | 111 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 112 | endloop = jpi |
---|
[8586] | 113 | ELSE |
---|
[14644] | 114 | endloop = jpi - khls |
---|
[8586] | 115 | ENDIF |
---|
[14644] | 116 | IF( nimpp >= Ni0glo/2+1 ) THEN |
---|
| 117 | startloop = khls |
---|
| 118 | ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN |
---|
| 119 | startloop = Ni0glo/2+1 - nimpp + khls |
---|
| 120 | ELSE |
---|
| 121 | startloop = endloop + 1 |
---|
[8586] | 122 | ENDIF |
---|
[14644] | 123 | IF( startloop <= endloop ) THEN |
---|
[10425] | 124 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 125 | DO ji = startloop, endloop |
---|
[13286] | 126 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 127 | jia = ji + nimpp - 1 |
---|
| 128 | ijua = jpiglo - jia + 1 |
---|
[10425] | 129 | IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN |
---|
[14644] | 130 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-khls,jk,jl) |
---|
[10425] | 131 | ELSE |
---|
[14644] | 132 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) |
---|
[10425] | 133 | ENDIF |
---|
| 134 | END DO |
---|
| 135 | END DO; END DO |
---|
[8586] | 136 | ENDIF |
---|
[14644] | 137 | ENDIF |
---|
| 138 | ! |
---|
| 139 | CASE ( 'V' ) ! V-point |
---|
| 140 | IF( nimpp /= 1 ) THEN |
---|
| 141 | startloop = 1 |
---|
| 142 | ELSE |
---|
| 143 | startloop = 1 + khls |
---|
| 144 | ENDIF |
---|
| 145 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
[10425] | 146 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 147 | DO jj = 2, khls+1 |
---|
| 148 | ijj = jpj -jj +1 |
---|
| 149 | DO ji = startloop, jpi |
---|
| 150 | ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 |
---|
| 151 | ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) |
---|
| 152 | END DO |
---|
[10425] | 153 | END DO |
---|
| 154 | END DO; END DO |
---|
[14644] | 155 | ENDIF |
---|
| 156 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 157 | DO ji = startloop, jpi |
---|
| 158 | ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 |
---|
| 159 | ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) |
---|
| 160 | END DO |
---|
| 161 | END DO; END DO |
---|
| 162 | IF (nimpp .eq. 1) THEN |
---|
| 163 | DO jj = 1, khls |
---|
| 164 | ijj = jpj-jj+1 |
---|
| 165 | DO ii = 0, khls-1 |
---|
| 166 | ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,:,:) |
---|
| 167 | END DO |
---|
| 168 | END DO |
---|
| 169 | ENDIF |
---|
| 170 | CASE ( 'F' ) ! F-point |
---|
| 171 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 172 | endloop = jpi |
---|
| 173 | ELSE |
---|
| 174 | endloop = jpi - khls |
---|
| 175 | ENDIF |
---|
| 176 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
| 177 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 178 | DO jj = 2, khls+1 |
---|
| 179 | ijj = jpj -jj +1 |
---|
| 180 | DO ji = 1, endloop |
---|
| 181 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 182 | ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) |
---|
| 183 | END DO |
---|
| 184 | END DO |
---|
| 185 | END DO; END DO |
---|
| 186 | ENDIF |
---|
| 187 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 188 | DO ji = 1, endloop |
---|
| 189 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 190 | ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) |
---|
| 191 | END DO |
---|
| 192 | END DO; END DO |
---|
| 193 | IF (nimpp .eq. 1) THEN |
---|
| 194 | DO ii = 1, khls |
---|
| 195 | ptab(ii,jpj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls-1,:,:) |
---|
| 196 | END DO |
---|
| 197 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
| 198 | DO jj = 1, khls |
---|
| 199 | ijj = jpj -jj |
---|
| 200 | DO ii = 0, khls-1 |
---|
| 201 | ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) |
---|
| 202 | END DO |
---|
| 203 | END DO |
---|
[8586] | 204 | ENDIF |
---|
[14644] | 205 | ENDIF |
---|
| 206 | IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN |
---|
| 207 | DO ii = 1, khls |
---|
| 208 | ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls-1,:,:) |
---|
| 209 | END DO |
---|
[10425] | 210 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
[14644] | 211 | DO jj = 1, khls |
---|
| 212 | ijj = jpj -jj |
---|
| 213 | DO ii = 1, khls |
---|
| 214 | ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) |
---|
| 215 | END DO |
---|
| 216 | END DO |
---|
[10425] | 217 | ENDIF |
---|
[14644] | 218 | ENDIF |
---|
| 219 | ! |
---|
| 220 | END SELECT |
---|
| 221 | ! |
---|
| 222 | ENDIF ! c_NFtype == 'T' |
---|
| 223 | ! |
---|
| 224 | IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot |
---|
| 225 | ! |
---|
| 226 | SELECT CASE ( cd_nat ) |
---|
| 227 | CASE ( 'T' , 'W' ) ! T-, W-point |
---|
| 228 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 229 | DO jj = 1, khls |
---|
| 230 | ijj = jpj-jj+1 |
---|
| 231 | DO ji = 1, jpi |
---|
| 232 | ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 233 | ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) |
---|
| 234 | END DO |
---|
| 235 | END DO |
---|
| 236 | END DO; END DO |
---|
| 237 | ! |
---|
| 238 | CASE ( 'U' ) ! U-point |
---|
| 239 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 240 | endloop = jpi |
---|
| 241 | ELSE |
---|
| 242 | endloop = jpi - khls |
---|
| 243 | ENDIF |
---|
| 244 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 245 | DO jj = 1, khls |
---|
| 246 | ijj = jpj-jj+1 |
---|
[10425] | 247 | DO ji = 1, endloop |
---|
[14644] | 248 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 |
---|
| 249 | ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) |
---|
[10425] | 250 | END DO |
---|
[14644] | 251 | END DO |
---|
| 252 | END DO; END DO |
---|
| 253 | IF(nimpp + jpi - 1 .eq. jpiglo) THEN |
---|
[10425] | 254 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 255 | DO jj = 1, khls |
---|
| 256 | ijj = jpj-jj+1 |
---|
| 257 | DO ii = 1, khls |
---|
| 258 | iij = jpi-ii+1 |
---|
| 259 | ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj,jk,jl) |
---|
[13286] | 260 | END DO |
---|
[14644] | 261 | END DO |
---|
[10425] | 262 | END DO; END DO |
---|
[14644] | 263 | ENDIF |
---|
| 264 | ! |
---|
| 265 | CASE ( 'V' ) ! V-point |
---|
| 266 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 267 | DO jj = 1, khls |
---|
| 268 | ijj = jpj -jj +1 |
---|
| 269 | DO ji = 1, jpi |
---|
| 270 | ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 271 | ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) |
---|
| 272 | END DO |
---|
| 273 | END DO |
---|
| 274 | END DO; END DO |
---|
| 275 | |
---|
| 276 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
| 277 | IF( nimpp >= Ni0glo/2+2 ) THEN |
---|
| 278 | startloop = 1 |
---|
| 279 | ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN |
---|
| 280 | startloop = Ni0glo/2+2 - nimpp + khls |
---|
[8586] | 281 | ELSE |
---|
[14644] | 282 | startloop = jpi + 1 |
---|
[8586] | 283 | ENDIF |
---|
[14644] | 284 | IF( startloop <= jpi ) THEN |
---|
[10425] | 285 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 286 | DO ji = startloop, jpi |
---|
| 287 | ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 |
---|
| 288 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) |
---|
[13286] | 289 | END DO |
---|
[10425] | 290 | END DO; END DO |
---|
[8586] | 291 | ENDIF |
---|
[14644] | 292 | ENDIF |
---|
| 293 | ! |
---|
| 294 | CASE ( 'F' ) ! F-point |
---|
| 295 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 296 | endloop = jpi |
---|
| 297 | ELSE |
---|
| 298 | endloop = jpi - khls |
---|
| 299 | ENDIF |
---|
| 300 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
| 301 | DO jj = 1, khls |
---|
| 302 | ijj = jpj -jj +1 |
---|
| 303 | DO ji = 1, endloop |
---|
| 304 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 |
---|
| 305 | ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) |
---|
| 306 | END DO |
---|
| 307 | END DO |
---|
| 308 | END DO; END DO |
---|
| 309 | IF((nimpp + jpi - 1) .eq. jpiglo) THEN |
---|
[10425] | 310 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 311 | DO jj = 1, khls |
---|
| 312 | ijj = jpj -jj +1 |
---|
| 313 | DO ii = 1, khls |
---|
| 314 | iij = jpi -ii+1 |
---|
| 315 | ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj-1,jk,jl) |
---|
[13286] | 316 | END DO |
---|
[10425] | 317 | END DO |
---|
| 318 | END DO; END DO |
---|
[14644] | 319 | ENDIF |
---|
| 320 | ! |
---|
| 321 | IF ( .NOT. l_fast_exchanges ) THEN |
---|
[13286] | 322 | IF( nimpp + jpi - 1 /= jpiglo ) THEN |
---|
| 323 | endloop = jpi |
---|
[8586] | 324 | ELSE |
---|
[14644] | 325 | endloop = jpi - khls |
---|
[8586] | 326 | ENDIF |
---|
[14644] | 327 | IF( nimpp >= Ni0glo/2+2 ) THEN |
---|
| 328 | startloop = 1 |
---|
| 329 | ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN |
---|
| 330 | startloop = Ni0glo/2+2 - nimpp + khls |
---|
| 331 | ELSE |
---|
| 332 | startloop = endloop + 1 |
---|
| 333 | ENDIF |
---|
| 334 | IF( startloop <= endloop ) THEN |
---|
[10425] | 335 | DO jl = 1, ipl; DO jk = 1, ipk |
---|
[14644] | 336 | DO ji = startloop, endloop |
---|
| 337 | iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 |
---|
| 338 | ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) |
---|
[13286] | 339 | END DO |
---|
[10425] | 340 | END DO; END DO |
---|
[8586] | 341 | ENDIF |
---|
[14644] | 342 | ENDIF |
---|
[8586] | 343 | ! |
---|
[14644] | 344 | END SELECT |
---|
[8586] | 345 | ! |
---|
[14644] | 346 | ENDIF ! c_NFtype == 'F' |
---|
| 347 | ! |
---|
| 348 | END SUBROUTINE lbc_nfd_nogather_/**/PRECISION |
---|
| 349 | |
---|