- Timestamp:
- 2017-06-28T10:02:58+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r7646 r8226 5 5 !!====================================================================== 6 6 !! History : 3.2 ! 2009-03 (R. Benshila) Original code 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 8 !! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 8 9 !!---------------------------------------------------------------------- 9 10 … … 12 13 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 13 14 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 14 !! mpp_lbc_nfd_3d : North fold treatment for a 3D arrays optimized for MPP 15 !! mpp_lbc_nfd_2d : North fold treatment for a 2D arrays optimized for MPP 15 !! lbc_nfd_nogather : generic interface for lbc_nfd_nogather_3d and 16 !! lbc_nfd_nogather_2d routines (designed for use 17 !! with ln_nnogather to avoid global width arrays 18 !! mpi all gather operations) 16 19 !!---------------------------------------------------------------------- 17 20 USE dom_oce ! ocean space and time domain … … 22 25 23 26 INTERFACE lbc_nfd 24 MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d 27 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 28 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 25 29 END INTERFACE 26 30 ! 27 INTERFACE mpp_lbc_nfd 28 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 31 INTERFACE lbc_nfd_nogather 32 ! ! Currently only 4d array version is needed 33 ! MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 34 MODULE PROCEDURE lbc_nfd_nogather_4d 35 ! MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 36 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 29 37 END INTERFACE 30 38 31 PUBLIC lbc_nfd ! north fold conditions 32 PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case) 39 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 40 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 41 END TYPE PTR_2D 42 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 43 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 44 END TYPE PTR_3D 45 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 46 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 47 END TYPE PTR_4D 48 49 PUBLIC lbc_nfd ! north fold conditions 50 PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) 33 51 34 52 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: … … 43 61 CONTAINS 44 62 45 SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 46 !!---------------------------------------------------------------------- 47 !! *** routine lbc_nfd_3d *** 48 !! 49 !! ** Purpose : 3D lateral boundary condition : North fold treatment 50 !! without processor exchanges. 51 !! 52 !! ** Method : 53 !! 54 !! ** Action : pt3d with updated values along the north fold 55 !!---------------------------------------------------------------------- 56 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 57 ! ! = T , U , V , F , W points 58 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 59 ! ! = -1. , the sign is changed if north fold boundary 60 ! ! = 1. , the sign is kept if north fold boundary 61 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied 62 ! 63 INTEGER :: ji, jk 64 INTEGER :: ijt, iju, ijpj, ijpjm1 65 !!---------------------------------------------------------------------- 66 67 SELECT CASE ( jpni ) 68 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 69 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 70 END SELECT 71 ijpjm1 = ijpj-1 72 73 DO jk = 1, jpk 74 ! 75 SELECT CASE ( npolj ) 76 ! 77 CASE ( 3 , 4 ) ! * North fold T-point pivot 78 ! 79 SELECT CASE ( cd_type ) 80 CASE ( 'T' , 'W' ) ! T-, W-point 81 DO ji = 2, jpiglo 82 ijt = jpiglo-ji+2 83 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 84 END DO 85 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 86 DO ji = jpiglo/2+1, jpiglo 87 ijt = jpiglo-ji+2 88 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 89 END DO 90 CASE ( 'U' ) ! U-point 91 DO ji = 1, jpiglo-1 92 iju = jpiglo-ji+1 93 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 94 END DO 95 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk) 96 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) 97 DO ji = jpiglo/2, jpiglo-1 98 iju = jpiglo-ji+1 99 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 100 END DO 101 CASE ( 'V' ) ! V-point 102 DO ji = 2, jpiglo 103 ijt = jpiglo-ji+2 104 pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 105 pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 106 END DO 107 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) 108 CASE ( 'F' ) ! F-point 109 DO ji = 1, jpiglo-1 110 iju = jpiglo-ji+1 111 pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 112 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk) 113 END DO 114 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk) 115 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) 116 END SELECT 117 ! 118 CASE ( 5 , 6 ) ! * North fold F-point pivot 119 ! 120 SELECT CASE ( cd_type ) 121 CASE ( 'T' , 'W' ) ! T-, W-point 122 DO ji = 1, jpiglo 123 ijt = jpiglo-ji+1 124 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 125 END DO 126 CASE ( 'U' ) ! U-point 127 DO ji = 1, jpiglo-1 128 iju = jpiglo-ji 129 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 130 END DO 131 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 132 CASE ( 'V' ) ! V-point 133 DO ji = 1, jpiglo 134 ijt = jpiglo-ji+1 135 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 136 END DO 137 DO ji = jpiglo/2+1, jpiglo 138 ijt = jpiglo-ji+1 139 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 140 END DO 141 CASE ( 'F' ) ! F-point 142 DO ji = 1, jpiglo-1 143 iju = jpiglo-ji 144 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk) 145 END DO 146 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 147 DO ji = jpiglo/2+1, jpiglo-1 148 iju = jpiglo-ji 149 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 150 END DO 151 END SELECT 152 ! 153 CASE DEFAULT ! * closed : the code probably never go through 154 ! 155 SELECT CASE ( cd_type) 156 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 157 pt3d(:, 1 ,jk) = 0.e0 158 pt3d(:,ijpj,jk) = 0.e0 159 CASE ( 'F' ) ! F-point 160 pt3d(:,ijpj,jk) = 0.e0 161 END SELECT 162 ! 163 END SELECT ! npolj 164 ! 165 END DO 166 ! 167 END SUBROUTINE lbc_nfd_3d 168 169 170 SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 63 !!---------------------------------------------------------------------- 64 !! *** routine lbc_nfd_(2,3,4)d *** 65 !!---------------------------------------------------------------------- 66 !! 67 !! ** Purpose : lateral boundary condition 68 !! North fold treatment without processor exchanges. 69 !! 70 !! ** Method : 71 !! 72 !! ** Action : ptab with updated values along the north fold 73 !!---------------------------------------------------------------------- 74 ! 75 ! !== 2D array and array of 2D pointer ==! 76 ! 77 # define DIM_2d 78 # define ROUTINE_NFD lbc_nfd_2d 79 # include "lbc_nfd_generic.h90" 80 # undef ROUTINE_NFD 81 # define MULTI 82 # define ROUTINE_NFD lbc_nfd_2d_ptr 83 # include "lbc_nfd_generic.h90" 84 # undef ROUTINE_NFD 85 # undef MULTI 86 # undef DIM_2d 87 ! 88 ! !== 3D array and array of 3D pointer ==! 89 ! 90 # define DIM_3d 91 # define ROUTINE_NFD lbc_nfd_3d 92 # include "lbc_nfd_generic.h90" 93 # undef ROUTINE_NFD 94 # define MULTI 95 # define ROUTINE_NFD lbc_nfd_3d_ptr 96 # include "lbc_nfd_generic.h90" 97 # undef ROUTINE_NFD 98 # undef MULTI 99 # undef DIM_3d 100 ! 101 ! !== 4D array and array of 4D pointer ==! 102 ! 103 # define DIM_4d 104 # define ROUTINE_NFD lbc_nfd_4d 105 # include "lbc_nfd_generic.h90" 106 # undef ROUTINE_NFD 107 # define MULTI 108 # define ROUTINE_NFD lbc_nfd_4d_ptr 109 # include "lbc_nfd_generic.h90" 110 # undef ROUTINE_NFD 111 # undef MULTI 112 # undef DIM_4d 113 ! 114 ! lbc_nfd_nogather routines 115 ! 116 ! !== 2D array and array of 2D pointer ==! 117 ! 118 !# define DIM_2d 119 !# define ROUTINE_NFD lbc_nfd_nogather_2d 120 !# include "lbc_nfd_nogather_generic.h90" 121 !# undef ROUTINE_NFD 122 !# define MULTI 123 !# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 124 !# include "lbc_nfd_nogather_generic.h90" 125 !# undef ROUTINE_NFD 126 !# undef MULTI 127 !# undef DIM_2d 128 ! 129 ! !== 3D array and array of 3D pointer ==! 130 ! 131 !# define DIM_3d 132 !# define ROUTINE_NFD lbc_nfd_nogather_3d 133 !# include "lbc_nfd_nogather_generic.h90" 134 !# undef ROUTINE_NFD 135 !# define MULTI 136 !# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 137 !# include "lbc_nfd_nogather_generic.h90" 138 !# undef ROUTINE_NFD 139 !# undef MULTI 140 !# undef DIM_3d 141 ! 142 ! !== 4D array and array of 4D pointer ==! 143 ! 144 # define DIM_4d 145 # define ROUTINE_NFD lbc_nfd_nogather_4d 146 # include "lbc_nfd_nogather_generic.h90" 147 # undef ROUTINE_NFD 148 !# define MULTI 149 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 150 !# include "lbc_nfd_nogather_generic.h90" 151 !# undef ROUTINE_NFD 152 !# undef MULTI 153 # undef DIM_4d 154 155 !!---------------------------------------------------------------------- 156 157 158 !!gm CAUTION HERE optional pr2dj not implemented in generic case 159 !!gm furthermore, in the _org routine it is OK only for T-point pivot !! 160 161 162 SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 171 163 !!---------------------------------------------------------------------- 172 164 !! *** routine lbc_nfd_2d *** … … 179 171 !! ** Action : pt2d with updated values along the north fold 180 172 !!---------------------------------------------------------------------- 181 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points182 ! ! = T , U , V , F , W points183 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change184 ! ! = -1. , the sign is changed if north fold boundary185 ! ! = 1. , the sign is kept if north fold boundary186 173 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 174 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of pt2d grid-point 175 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 187 176 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos 188 177 ! … … 210 199 CASE ( 3, 4 ) ! * North fold T-point pivot 211 200 ! 212 SELECT CASE ( cd_ type)201 SELECT CASE ( cd_nat ) 213 202 ! 214 203 CASE ( 'T' , 'W' ) ! T- , W-points … … 265 254 END DO 266 255 END DO 267 CASE ( 'J' ) ! first ice U-V point268 DO jl =0, ipr2dj269 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)270 DO ji = 3, jpiglo271 iju = jpiglo - ji + 3272 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)273 END DO274 END DO275 CASE ( 'K' ) ! second ice U-V point276 DO jl =0, ipr2dj277 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)278 DO ji = 3, jpiglo279 iju = jpiglo - ji + 3280 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)281 END DO282 END DO283 256 END SELECT 284 257 ! 285 258 CASE ( 5, 6 ) ! * North fold F-point pivot 286 259 ! 287 SELECT CASE ( cd_ type)260 SELECT CASE ( cd_nat ) 288 261 CASE ( 'T' , 'W' ) ! T-, W-point 289 262 DO jl = 0, ipr2dj … … 325 298 END DO 326 299 CASE ( 'I' ) ! ice U-V point (I-point) 327 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0. e0300 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 328 301 DO jl = 0, ipr2dj 329 302 DO ji = 2 , jpiglo-1 … … 332 305 END DO 333 306 END DO 334 CASE ( 'J' ) ! first ice U-V point335 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0336 DO jl = 0, ipr2dj337 DO ji = 2 , jpiglo-1338 ijt = jpiglo - ji + 2339 pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl)340 END DO341 END DO342 CASE ( 'K' ) ! second ice U-V point343 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0344 DO jl = 0, ipr2dj345 DO ji = 2 , jpiglo-1346 ijt = jpiglo - ji + 2347 pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl)348 END DO349 END DO350 307 END SELECT 351 308 ! 352 309 CASE DEFAULT ! * closed : the code probably never go through 353 310 ! 354 SELECT CASE ( cd_ type)311 SELECT CASE ( cd_nat) 355 312 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 356 pt2d(:, 1:1-ipr2dj ) = 0. e0357 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0313 pt2d(:, 1:1-ipr2dj ) = 0._wp 314 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 358 315 CASE ( 'F' ) ! F-point 359 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0316 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 360 317 CASE ( 'I' ) ! ice U-V point 361 pt2d(:, 1:1-ipr2dj ) = 0.e0 362 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 363 CASE ( 'J' ) ! first ice U-V point 364 pt2d(:, 1:1-ipr2dj ) = 0.e0 365 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 366 CASE ( 'K' ) ! second ice U-V point 367 pt2d(:, 1:1-ipr2dj ) = 0.e0 368 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 318 pt2d(:, 1:1-ipr2dj ) = 0._wp 319 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 369 320 END SELECT 370 321 ! 371 322 END SELECT 372 323 ! 373 END SUBROUTINE lbc_nfd_2d 374 375 376 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 377 !!---------------------------------------------------------------------- 378 !! *** routine mpp_lbc_nfd_3d *** 379 !! 380 !! ** Purpose : 3D lateral boundary condition : North fold treatment 381 !! without processor exchanges. 382 !! 383 !! ** Method : 384 !! 385 !! ** Action : pt3d with updated values along the north fold 386 !!---------------------------------------------------------------------- 387 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 388 ! ! = T , U , V , F , W points 389 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 390 ! ! = -1. , the sign is changed if north fold boundary 391 ! ! = 1. , the sign is kept if north fold boundary 392 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 393 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied 394 ! 395 INTEGER :: ji, jk 396 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 397 !!---------------------------------------------------------------------- 398 ! 399 SELECT CASE ( jpni ) 400 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 401 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 402 END SELECT 403 ijpjm1 = ijpj-1 404 405 ! 406 SELECT CASE ( npolj ) 407 ! 408 CASE ( 3 , 4 ) ! * North fold T-point pivot 409 ! 410 SELECT CASE ( cd_type ) 411 CASE ( 'T' , 'W' ) ! T-, W-point 412 IF (nimpp .ne. 1) THEN 413 startloop = 1 414 ELSE 415 startloop = 2 416 ENDIF 417 418 DO jk = 1, jpk 419 DO ji = startloop, nlci 420 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 421 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 422 END DO 423 IF(nimpp .eq. 1) THEN 424 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 425 ENDIF 426 END DO 427 428 IF(nimpp .ge. (jpiglo/2+1)) THEN 429 startloop = 1 430 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 431 startloop = jpiglo/2+1 - nimpp + 1 432 ELSE 433 startloop = nlci + 1 434 ENDIF 435 IF(startloop .le. nlci) THEN 436 DO jk = 1, jpk 437 DO ji = startloop, nlci 438 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 439 jia = ji + nimpp - 1 440 ijta = jpiglo - jia + 2 441 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 442 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 443 ELSE 444 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 445 ENDIF 446 END DO 447 END DO 448 ENDIF 449 450 451 CASE ( 'U' ) ! U-point 452 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 453 endloop = nlci 454 ELSE 455 endloop = nlci - 1 456 ENDIF 457 DO jk = 1, jpk 458 DO ji = 1, endloop 459 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 460 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 461 END DO 462 IF(nimpp .eq. 1) THEN 463 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk) 464 ENDIF 465 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 466 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 467 ENDIF 468 END DO 469 470 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 471 endloop = nlci 472 ELSE 473 endloop = nlci - 1 474 ENDIF 475 IF(nimpp .ge. (jpiglo/2)) THEN 476 startloop = 1 477 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 478 startloop = jpiglo/2 - nimpp + 1 479 ELSE 480 startloop = endloop + 1 481 ENDIF 482 IF (startloop .le. endloop) THEN 483 DO jk = 1, jpk 484 DO ji = startloop, endloop 485 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 486 jia = ji + nimpp - 1 487 ijua = jpiglo - jia + 1 488 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 489 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 490 ELSE 491 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 492 ENDIF 493 END DO 494 END DO 495 ENDIF 496 497 CASE ( 'V' ) ! V-point 498 IF (nimpp .ne. 1) THEN 499 startloop = 1 500 ELSE 501 startloop = 2 502 ENDIF 503 DO jk = 1, jpk 504 DO ji = startloop, nlci 505 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 506 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 507 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 508 END DO 509 IF(nimpp .eq. 1) THEN 510 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 511 ENDIF 512 END DO 513 CASE ( 'F' ) ! F-point 514 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 515 endloop = nlci 516 ELSE 517 endloop = nlci - 1 518 ENDIF 519 DO jk = 1, jpk 520 DO ji = 1, endloop 521 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 522 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 523 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 524 END DO 525 IF(nimpp .eq. 1) THEN 526 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk) 527 ENDIF 528 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 529 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 530 ENDIF 531 END DO 532 END SELECT 533 ! 534 535 CASE ( 5 , 6 ) ! * North fold F-point pivot 536 ! 537 SELECT CASE ( cd_type ) 538 CASE ( 'T' , 'W' ) ! T-, W-point 539 DO jk = 1, jpk 540 DO ji = 1, nlci 541 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 542 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 543 END DO 544 END DO 545 546 CASE ( 'U' ) ! U-point 547 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 548 endloop = nlci 549 ELSE 550 endloop = nlci - 1 551 ENDIF 552 DO jk = 1, jpk 553 DO ji = 1, endloop 554 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 555 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 556 END DO 557 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 558 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 559 ENDIF 560 END DO 561 562 CASE ( 'V' ) ! V-point 563 DO jk = 1, jpk 564 DO ji = 1, nlci 565 ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 566 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 567 END DO 568 END DO 569 570 IF(nimpp .ge. (jpiglo/2+1)) THEN 571 startloop = 1 572 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 573 startloop = jpiglo/2+1 - nimpp + 1 574 ELSE 575 startloop = nlci + 1 576 ENDIF 577 IF(startloop .le. nlci) THEN 578 DO jk = 1, jpk 579 DO ji = startloop, nlci 580 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 581 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 582 END DO 583 END DO 584 ENDIF 585 586 CASE ( 'F' ) ! F-point 587 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 588 endloop = nlci 589 ELSE 590 endloop = nlci - 1 591 ENDIF 592 DO jk = 1, jpk 593 DO ji = 1, endloop 594 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 595 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 596 END DO 597 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 598 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 599 ENDIF 600 END DO 601 602 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 603 endloop = nlci 604 ELSE 605 endloop = nlci - 1 606 ENDIF 607 IF(nimpp .ge. (jpiglo/2+1)) THEN 608 startloop = 1 609 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 610 startloop = jpiglo/2+1 - nimpp + 1 611 ELSE 612 startloop = endloop + 1 613 ENDIF 614 IF (startloop .le. endloop) THEN 615 DO jk = 1, jpk 616 DO ji = startloop, endloop 617 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 618 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 619 END DO 620 END DO 621 ENDIF 622 623 END SELECT 624 625 CASE DEFAULT ! * closed : the code probably never go through 626 ! 627 SELECT CASE ( cd_type) 628 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 629 pt3dl(:, 1 ,jk) = 0.e0 630 pt3dl(:,ijpj,jk) = 0.e0 631 CASE ( 'F' ) ! F-point 632 pt3dl(:,ijpj,jk) = 0.e0 633 END SELECT 634 ! 635 END SELECT ! npolj 636 ! 637 ! 638 END SUBROUTINE mpp_lbc_nfd_3d 639 640 641 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 642 !!---------------------------------------------------------------------- 643 !! *** routine mpp_lbc_nfd_2d *** 644 !! 645 !! ** Purpose : 2D lateral boundary condition : North fold treatment 646 !! without processor exchanges. 647 !! 648 !! ** Method : 649 !! 650 !! ** Action : pt2d with updated values along the north fold 651 !!---------------------------------------------------------------------- 652 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 653 ! ! = T , U , V , F , W points 654 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 655 ! ! = -1. , the sign is changed if north fold boundary 656 ! ! = 1. , the sign is kept if north fold boundary 657 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 658 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied 659 ! 660 INTEGER :: ji 661 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 662 !!---------------------------------------------------------------------- 663 664 SELECT CASE ( jpni ) 665 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 666 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 667 END SELECT 668 ! 669 ijpjm1 = ijpj-1 670 671 672 SELECT CASE ( npolj ) 673 ! 674 CASE ( 3, 4 ) ! * North fold T-point pivot 675 ! 676 SELECT CASE ( cd_type ) 677 ! 678 CASE ( 'T' , 'W' ) ! T- , W-points 679 IF (nimpp .ne. 1) THEN 680 startloop = 1 681 ELSE 682 startloop = 2 683 ENDIF 684 DO ji = startloop, nlci 685 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 686 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 687 END DO 688 IF (nimpp .eq. 1) THEN 689 pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 690 ENDIF 691 692 IF(nimpp .ge. (jpiglo/2+1)) THEN 693 startloop = 1 694 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 695 startloop = jpiglo/2+1 - nimpp + 1 696 ELSE 697 startloop = nlci + 1 698 ENDIF 699 DO ji = startloop, nlci 700 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 701 jia = ji + nimpp - 1 702 ijta = jpiglo - jia + 2 703 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 704 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 705 ELSE 706 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 707 ENDIF 708 END DO 709 710 CASE ( 'U' ) ! U-point 711 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 712 endloop = nlci 713 ELSE 714 endloop = nlci - 1 715 ENDIF 716 DO ji = 1, endloop 717 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 718 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 719 END DO 720 721 IF (nimpp .eq. 1) THEN 722 pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) 723 pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 724 ENDIF 725 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 726 pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) 727 ENDIF 728 729 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 730 endloop = nlci 731 ELSE 732 endloop = nlci - 1 733 ENDIF 734 IF(nimpp .ge. (jpiglo/2)) THEN 735 startloop = 1 736 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 737 startloop = jpiglo/2 - nimpp + 1 738 ELSE 739 startloop = endloop + 1 740 ENDIF 741 DO ji = startloop, endloop 742 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 743 jia = ji + nimpp - 1 744 ijua = jpiglo - jia + 1 745 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 746 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 747 ELSE 748 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 749 ENDIF 750 END DO 751 752 CASE ( 'V' ) ! V-point 753 IF (nimpp .ne. 1) THEN 754 startloop = 1 755 ELSE 756 startloop = 2 757 ENDIF 758 DO ji = startloop, nlci 759 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 760 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 761 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 762 END DO 763 IF (nimpp .eq. 1) THEN 764 pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) 765 ENDIF 766 767 CASE ( 'F' ) ! F-point 768 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 769 endloop = nlci 770 ELSE 771 endloop = nlci - 1 772 ENDIF 773 DO ji = 1, endloop 774 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 775 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 776 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 777 END DO 778 IF (nimpp .eq. 1) THEN 779 pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3) 780 pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2) 781 ENDIF 782 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 783 pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3) 784 pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 785 ENDIF 786 787 CASE ( 'I' ) ! ice U-V point (I-point) 788 IF (nimpp .ne. 1) THEN 789 startloop = 1 790 ELSE 791 startloop = 3 792 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 793 ENDIF 794 DO ji = startloop, nlci 795 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 796 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 797 END DO 798 799 CASE ( 'J' ) ! first ice U-V point 800 IF (nimpp .ne. 1) THEN 801 startloop = 1 802 ELSE 803 startloop = 3 804 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 805 ENDIF 806 DO ji = startloop, nlci 807 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 808 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 809 END DO 810 811 CASE ( 'K' ) ! second ice U-V point 812 IF (nimpp .ne. 1) THEN 813 startloop = 1 814 ELSE 815 startloop = 3 816 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 817 ENDIF 818 DO ji = startloop, nlci 819 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 820 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 821 END DO 822 823 END SELECT 824 ! 825 CASE ( 5, 6 ) ! * North fold F-point pivot 826 ! 827 SELECT CASE ( cd_type ) 828 CASE ( 'T' , 'W' ) ! T-, W-point 829 DO ji = 1, nlci 830 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 831 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 832 END DO 833 834 CASE ( 'U' ) ! U-point 835 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 836 endloop = nlci 837 ELSE 838 endloop = nlci - 1 839 ENDIF 840 DO ji = 1, endloop 841 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 842 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 843 END DO 844 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 845 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 846 ENDIF 847 848 CASE ( 'V' ) ! V-point 849 DO ji = 1, nlci 850 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 851 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 852 END DO 853 IF(nimpp .ge. (jpiglo/2+1)) THEN 854 startloop = 1 855 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 856 startloop = jpiglo/2+1 - nimpp + 1 857 ELSE 858 startloop = nlci + 1 859 ENDIF 860 DO ji = startloop, nlci 861 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 862 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 863 END DO 864 865 CASE ( 'F' ) ! F-point 866 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 867 endloop = nlci 868 ELSE 869 endloop = nlci - 1 870 ENDIF 871 DO ji = 1, endloop 872 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 873 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 874 END DO 875 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 876 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 877 ENDIF 878 879 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 880 endloop = nlci 881 ELSE 882 endloop = nlci - 1 883 ENDIF 884 IF(nimpp .ge. (jpiglo/2+1)) THEN 885 startloop = 1 886 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 887 startloop = jpiglo/2+1 - nimpp + 1 888 ELSE 889 startloop = endloop + 1 890 ENDIF 891 892 DO ji = startloop, endloop 893 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 894 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 895 END DO 896 897 CASE ( 'I' ) ! ice U-V point (I-point) 898 IF (nimpp .ne. 1) THEN 899 startloop = 1 900 ELSE 901 startloop = 2 902 ENDIF 903 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 904 endloop = nlci 905 ELSE 906 endloop = nlci - 1 907 ENDIF 908 DO ji = startloop , endloop 909 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 910 pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 911 END DO 912 913 CASE ( 'J' ) ! first ice U-V point 914 IF (nimpp .ne. 1) THEN 915 startloop = 1 916 ELSE 917 startloop = 2 918 ENDIF 919 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 920 endloop = nlci 921 ELSE 922 endloop = nlci - 1 923 ENDIF 924 DO ji = startloop , endloop 925 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 926 pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 927 END DO 928 929 CASE ( 'K' ) ! second ice U-V point 930 IF (nimpp .ne. 1) THEN 931 startloop = 1 932 ELSE 933 startloop = 2 934 ENDIF 935 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 936 endloop = nlci 937 ELSE 938 endloop = nlci - 1 939 ENDIF 940 DO ji = startloop, endloop 941 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 942 pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 943 END DO 944 945 END SELECT 946 ! 947 CASE DEFAULT ! * closed : the code probably never go through 948 ! 949 SELECT CASE ( cd_type) 950 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 951 pt2dl(:, 1 ) = 0.e0 952 pt2dl(:,ijpj) = 0.e0 953 CASE ( 'F' ) ! F-point 954 pt2dl(:,ijpj) = 0.e0 955 CASE ( 'I' ) ! ice U-V point 956 pt2dl(:, 1 ) = 0.e0 957 pt2dl(:,ijpj) = 0.e0 958 CASE ( 'J' ) ! first ice U-V point 959 pt2dl(:, 1 ) = 0.e0 960 pt2dl(:,ijpj) = 0.e0 961 CASE ( 'K' ) ! second ice U-V point 962 pt2dl(:, 1 ) = 0.e0 963 pt2dl(:,ijpj) = 0.e0 964 END SELECT 965 ! 966 END SELECT 967 ! 968 END SUBROUTINE mpp_lbc_nfd_2d 324 END SUBROUTINE lbc_nfd_2d_org 969 325 970 326 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.