- Timestamp:
- 2017-06-19T11:25:07+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r8170 r8186 13 13 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 14 14 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 15 !! mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP16 !! mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP15 ! !! mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 16 ! !! mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 17 17 !!---------------------------------------------------------------------- 18 18 USE dom_oce ! ocean space and time domain … … 23 23 24 24 INTERFACE lbc_nfd 25 MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d 25 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 26 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 26 27 END INTERFACE 27 28 ! 28 INTERFACE mpp_lbc_nfd 29 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 30 END INTERFACE 29 !!gm INTERFACE mpp_lbc_nfd 30 !!gm MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 31 !!gm END INTERFACE 32 33 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 34 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 35 END TYPE PTR_2D 36 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 37 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 38 END TYPE PTR_3D 39 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 40 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 41 END TYPE PTR_4D 31 42 32 43 PUBLIC lbc_nfd ! north fold conditions 33 PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case)44 !!gm PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case) 34 45 35 46 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: … … 44 55 CONTAINS 45 56 46 SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 47 !!---------------------------------------------------------------------- 48 !! *** routine lbc_nfd_3d *** 49 !! 50 !! ** Purpose : 3D lateral boundary condition : North fold treatment 51 !! without processor exchanges. 52 !! 53 !! ** Method : 54 !! 55 !! ** Action : pt3d with updated values along the north fold 56 !!---------------------------------------------------------------------- 57 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied 58 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-point 59 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 60 ! 61 INTEGER :: ji, jk 62 INTEGER :: ijt, iju, ijpj, ijpjm1 63 !!---------------------------------------------------------------------- 64 ! 65 SELECT CASE ( jpni ) 66 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 67 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 68 END SELECT 69 ijpjm1 = ijpj-1 70 71 DO jk = 1, SIZE( pt3d, 3 ) 72 ! 73 SELECT CASE ( npolj ) 74 ! 75 CASE ( 3 , 4 ) ! * North fold T-point pivot 76 ! 77 SELECT CASE ( cd_type ) 78 CASE ( 'T' , 'W' ) ! T-, W-point 79 DO ji = 2, jpiglo 80 ijt = jpiglo-ji+2 81 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 82 END DO 83 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 84 DO ji = jpiglo/2+1, jpiglo 85 ijt = jpiglo-ji+2 86 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 87 END DO 88 CASE ( 'U' ) ! U-point 89 DO ji = 1, jpiglo-1 90 iju = jpiglo-ji+1 91 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 92 END DO 93 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk) 94 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) 95 DO ji = jpiglo/2, jpiglo-1 96 iju = jpiglo-ji+1 97 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 98 END DO 99 CASE ( 'V' ) ! V-point 100 DO ji = 2, jpiglo 101 ijt = jpiglo-ji+2 102 pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 103 pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 104 END DO 105 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) 106 CASE ( 'F' ) ! F-point 107 DO ji = 1, jpiglo-1 108 iju = jpiglo-ji+1 109 pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 110 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk) 111 END DO 112 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk) 113 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) 114 END SELECT 115 ! 116 CASE ( 5 , 6 ) ! * North fold F-point pivot 117 ! 118 SELECT CASE ( cd_type ) 119 CASE ( 'T' , 'W' ) ! T-, W-point 120 DO ji = 1, jpiglo 121 ijt = jpiglo-ji+1 122 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 123 END DO 124 CASE ( 'U' ) ! U-point 125 DO ji = 1, jpiglo-1 126 iju = jpiglo-ji 127 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 128 END DO 129 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 130 CASE ( 'V' ) ! V-point 131 DO ji = 1, jpiglo 132 ijt = jpiglo-ji+1 133 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 134 END DO 135 DO ji = jpiglo/2+1, jpiglo 136 ijt = jpiglo-ji+1 137 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 138 END DO 139 CASE ( 'F' ) ! F-point 140 DO ji = 1, jpiglo-1 141 iju = jpiglo-ji 142 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk) 143 END DO 144 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 145 DO ji = jpiglo/2+1, jpiglo-1 146 iju = jpiglo-ji 147 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 148 END DO 149 END SELECT 150 ! 151 CASE DEFAULT ! * closed : the code probably never go through 152 ! 153 SELECT CASE ( cd_type) 154 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 155 pt3d(:, 1 ,jk) = 0._wp 156 pt3d(:,ijpj,jk) = 0._wp 157 CASE ( 'F' ) ! F-point 158 pt3d(:,ijpj,jk) = 0._wp 159 END SELECT 160 ! 161 END SELECT ! npolj 162 ! 163 END DO 164 ! 165 END SUBROUTINE lbc_nfd_3d 166 167 168 SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 57 !!---------------------------------------------------------------------- 58 !! *** routine lbc_nfd_(2,3,4)d *** 59 !!---------------------------------------------------------------------- 60 !! 61 !! ** Purpose : lateral boundary condition 62 !! North fold treatment without processor exchanges. 63 !! 64 !! ** Method : 65 !! 66 !! ** Action : ptab with updated values along the north fold 67 !!---------------------------------------------------------------------- 68 ! 69 ! !== 2D array and array of 2D pointer ==! 70 ! 71 # define DIM_2d 72 # define ROUTINE_NFD lbc_nfd_2d 73 # include "lbc_nfd_generic.h90" 74 # undef ROUTINE_NFD 75 # define MULTI 76 # define ROUTINE_NFD lbc_nfd_2d_ptr 77 # include "lbc_nfd_generic.h90" 78 # undef ROUTINE_NFD 79 # undef MULTI 80 # undef DIM_2d 81 ! 82 ! !== 3D array and array of 3D pointer ==! 83 ! 84 # define DIM_3d 85 # define ROUTINE_NFD lbc_nfd_3d 86 # include "lbc_nfd_generic.h90" 87 # undef ROUTINE_NFD 88 # define MULTI 89 # define ROUTINE_NFD lbc_nfd_3d_ptr 90 # include "lbc_nfd_generic.h90" 91 # undef ROUTINE_NFD 92 # undef MULTI 93 # undef DIM_3d 94 ! 95 ! !== 4D array and array of 4D pointer ==! 96 ! 97 # define DIM_4d 98 # define ROUTINE_NFD lbc_nfd_4d 99 # include "lbc_nfd_generic.h90" 100 # undef ROUTINE_NFD 101 # define MULTI 102 # define ROUTINE_NFD lbc_nfd_4d_ptr 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # undef MULTI 106 # undef DIM_4d 107 108 !!---------------------------------------------------------------------- 109 110 111 !!gm CAUTION HERE optional pr2dj not implemented in generic case 112 !!gm furthermore, in the _org routine it is OK only for T-point pivot !! 113 114 115 SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 169 116 !!---------------------------------------------------------------------- 170 117 !! *** routine lbc_nfd_2d *** … … 178 125 !!---------------------------------------------------------------------- 179 126 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 180 CHARACTER(len=1) , INTENT(in ) :: cd_ type! nature of pt2d grid-point127 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of pt2d grid-point 181 128 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 182 129 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos … … 205 152 CASE ( 3, 4 ) ! * North fold T-point pivot 206 153 ! 207 SELECT CASE ( cd_ type)154 SELECT CASE ( cd_nat ) 208 155 ! 209 156 CASE ( 'T' , 'W' ) ! T- , W-points … … 264 211 CASE ( 5, 6 ) ! * North fold F-point pivot 265 212 ! 266 SELECT CASE ( cd_ type)213 SELECT CASE ( cd_nat ) 267 214 CASE ( 'T' , 'W' ) ! T-, W-point 268 215 DO jl = 0, ipr2dj … … 315 262 CASE DEFAULT ! * closed : the code probably never go through 316 263 ! 317 SELECT CASE ( cd_ type)264 SELECT CASE ( cd_nat) 318 265 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 319 266 pt2d(:, 1:1-ipr2dj ) = 0._wp … … 328 275 END SELECT 329 276 ! 330 END SUBROUTINE lbc_nfd_2d 331 332 333 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 334 !!---------------------------------------------------------------------- 335 !! *** routine mpp_lbc_nfd_3d *** 336 !! 337 !! ** Purpose : 3D lateral boundary condition : North fold treatment 338 !! without processor exchanges. 339 !! 340 !! ** Method : 341 !! 342 !! ** Action : pt3d with updated values along the north fold 343 !!---------------------------------------------------------------------- 344 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 345 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied 346 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point 347 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 348 ! 349 INTEGER :: ji, jk ! dummy loop indices 350 INTEGER :: ipk ! 3rd dimension of the input array 351 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 352 !!---------------------------------------------------------------------- 353 ! 354 ipk = SIZE( pt3dl, 3 ) 355 ! 356 SELECT CASE ( jpni ) 357 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 358 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 359 END SELECT 360 ijpjm1 = ijpj-1 361 ! 362 ! 363 SELECT CASE ( npolj ) 364 ! 365 CASE ( 3 , 4 ) ! * North fold T-point pivot 366 ! 367 SELECT CASE ( cd_type ) 368 CASE ( 'T' , 'W' ) ! T-, W-point 369 IF ( nimpp /= 1 ) THEN ; startloop = 1 370 ELSE ; startloop = 2 371 ENDIF 372 ! 373 DO jk = 1, ipk 374 DO ji = startloop, nlci 375 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 376 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 377 END DO 378 IF(nimpp .eq. 1) THEN 379 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 380 ENDIF 381 END DO 382 383 IF( nimpp >= jpiglo/2+1 ) THEN 384 startloop = 1 385 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 386 startloop = jpiglo/2+1 - nimpp + 1 387 ELSE 388 startloop = nlci + 1 389 ENDIF 390 IF(startloop <= nlci) THEN 391 DO jk = 1, ipk 392 DO ji = startloop, nlci 393 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 394 jia = ji + nimpp - 1 395 ijta = jpiglo - jia + 2 396 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 397 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 398 ELSE 399 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 400 ENDIF 401 END DO 402 END DO 403 ENDIF 404 ! 405 CASE ( 'U' ) ! U-point 406 IF( nimpp + nlci - 1 /= jpiglo ) THEN 407 endloop = nlci 408 ELSE 409 endloop = nlci - 1 410 ENDIF 411 DO jk = 1, ipk 412 DO ji = 1, endloop 413 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 414 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 415 END DO 416 IF(nimpp .eq. 1) THEN 417 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk) 418 ENDIF 419 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 420 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 421 ENDIF 422 END DO 423 ! 424 IF( nimpp + nlci - 1 /= jpiglo ) THEN 425 endloop = nlci 426 ELSE 427 endloop = nlci - 1 428 ENDIF 429 IF( nimpp >= jpiglo/2 ) THEN 430 startloop = 1 431 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 432 startloop = jpiglo/2 - nimpp + 1 433 ELSE 434 startloop = endloop + 1 435 ENDIF 436 IF( startloop <= endloop ) THEN 437 DO jk = 1, ipk 438 DO ji = startloop, endloop 439 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 440 jia = ji + nimpp - 1 441 ijua = jpiglo - jia + 1 442 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 443 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 444 ELSE 445 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 446 ENDIF 447 END DO 448 END DO 449 ENDIF 450 ! 451 CASE ( 'V' ) ! V-point 452 IF( nimpp /= 1 ) THEN 453 startloop = 1 454 ELSE 455 startloop = 2 456 ENDIF 457 DO jk = 1, ipk 458 DO ji = startloop, nlci 459 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 460 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 461 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 462 END DO 463 IF(nimpp .eq. 1) THEN 464 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 465 ENDIF 466 END DO 467 CASE ( 'F' ) ! F-point 468 IF( nimpp + nlci - 1 /= jpiglo ) THEN 469 endloop = nlci 470 ELSE 471 endloop = nlci - 1 472 ENDIF 473 DO jk = 1, ipk 474 DO ji = 1, endloop 475 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 476 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 477 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 478 END DO 479 IF(nimpp .eq. 1) THEN 480 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk) 481 ENDIF 482 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 483 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 484 ENDIF 485 END DO 486 END SELECT 487 ! 488 CASE ( 5 , 6 ) ! * North fold F-point pivot 489 ! 490 SELECT CASE ( cd_type ) 491 CASE ( 'T' , 'W' ) ! T-, W-point 492 DO jk = 1, ipk 493 DO ji = 1, nlci 494 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 495 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 496 END DO 497 END DO 498 ! 499 CASE ( 'U' ) ! U-point 500 IF( nimpp + nlci - 1 /= jpiglo ) THEN 501 endloop = nlci 502 ELSE 503 endloop = nlci - 1 504 ENDIF 505 DO jk = 1, ipk 506 DO ji = 1, endloop 507 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 508 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 509 END DO 510 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 511 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 512 ENDIF 513 END DO 514 ! 515 CASE ( 'V' ) ! V-point 516 DO jk = 1, ipk 517 DO ji = 1, nlci 518 ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 519 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 520 END DO 521 END DO 522 ! 523 IF( nimpp >= jpiglo/2+1 ) THEN 524 startloop = 1 525 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 526 startloop = jpiglo/2+1 - nimpp + 1 527 ELSE 528 startloop = nlci + 1 529 ENDIF 530 IF( startloop <= nlci ) THEN 531 DO jk = 1, ipk 532 DO ji = startloop, nlci 533 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 534 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 535 END DO 536 END DO 537 ENDIF 538 ! 539 CASE ( 'F' ) ! F-point 540 IF( nimpp + nlci - 1 /= jpiglo ) THEN 541 endloop = nlci 542 ELSE 543 endloop = nlci - 1 544 ENDIF 545 DO jk = 1, ipk 546 DO ji = 1, endloop 547 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 548 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 549 END DO 550 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 551 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 552 ENDIF 553 END DO 554 ! 555 IF( nimpp + nlci - 1 /= jpiglo ) THEN 556 endloop = nlci 557 ELSE 558 endloop = nlci - 1 559 ENDIF 560 IF( nimpp >= jpiglo/2+1 ) THEN 561 startloop = 1 562 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 563 startloop = jpiglo/2+1 - nimpp + 1 564 ELSE 565 startloop = endloop + 1 566 ENDIF 567 IF( startloop <= endloop ) THEN 568 DO jk = 1, ipk 569 DO ji = startloop, endloop 570 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 571 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 572 END DO 573 END DO 574 ENDIF 575 ! 576 END SELECT 577 ! 578 CASE DEFAULT ! * closed : the code probably never go through 579 ! 580 SELECT CASE ( cd_type) 581 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 582 pt3dl(:, 1 ,jk) = 0._wp 583 pt3dl(:,ijpj,jk) = 0._wp 584 CASE ( 'F' ) ! F-point 585 pt3dl(:,ijpj,jk) = 0._wp 586 END SELECT 587 ! 588 END SELECT ! npolj 589 ! 590 END SUBROUTINE mpp_lbc_nfd_3d 591 592 593 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 594 !!---------------------------------------------------------------------- 595 !! *** routine mpp_lbc_nfd_2d *** 596 !! 597 !! ** Purpose : 2D lateral boundary condition : North fold treatment 598 !! without processor exchanges. 599 !! 600 !! ** Method : 601 !! 602 !! ** Action : pt2dl with updated values along the north fold 603 !!---------------------------------------------------------------------- 604 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 605 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied 606 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point 607 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 608 ! 609 INTEGER :: ji 610 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 611 !!---------------------------------------------------------------------- 612 613 SELECT CASE ( jpni ) 614 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 615 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 616 END SELECT 617 ! 618 ijpjm1 = ijpj-1 619 ! 620 ! 621 SELECT CASE ( npolj ) 622 ! 623 CASE ( 3, 4 ) ! * North fold T-point pivot 624 ! 625 SELECT CASE ( cd_type ) 626 ! 627 CASE ( 'T' , 'W' ) ! T- , W-points 628 IF( nimpp /= 1 ) THEN 629 startloop = 1 630 ELSE 631 startloop = 2 632 ENDIF 633 DO ji = startloop, nlci 634 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 635 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 636 END DO 637 IF( nimpp == 1 ) THEN 638 pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 639 ENDIF 640 ! 641 IF( nimpp >= jpiglo/2+1 ) THEN 642 startloop = 1 643 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 644 startloop = jpiglo/2+1 - nimpp + 1 645 ELSE 646 startloop = nlci + 1 647 ENDIF 648 DO ji = startloop, nlci 649 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 650 jia = ji + nimpp - 1 651 ijta = jpiglo - jia + 2 652 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 653 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 654 ELSE 655 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 656 ENDIF 657 END DO 658 ! 659 CASE ( 'U' ) ! U-point 660 IF( nimpp + nlci - 1 /= jpiglo ) THEN 661 endloop = nlci 662 ELSE 663 endloop = nlci - 1 664 ENDIF 665 DO ji = 1, endloop 666 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 667 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 668 END DO 669 ! 670 IF (nimpp .eq. 1) THEN 671 pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) 672 pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 673 ENDIF 674 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 675 pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) 676 ENDIF 677 ! 678 IF( nimpp + nlci - 1 /= jpiglo ) THEN 679 endloop = nlci 680 ELSE 681 endloop = nlci - 1 682 ENDIF 683 IF( nimpp >= jpiglo/2 ) THEN 684 startloop = 1 685 ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 686 startloop = jpiglo/2 - nimpp + 1 687 ELSE 688 startloop = endloop + 1 689 ENDIF 690 DO ji = startloop, endloop 691 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 692 jia = ji + nimpp - 1 693 ijua = jpiglo - jia + 1 694 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 695 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 696 ELSE 697 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 698 ENDIF 699 END DO 700 ! 701 CASE ( 'V' ) ! V-point 702 IF( nimpp /= 1 ) THEN 703 startloop = 1 704 ELSE 705 startloop = 2 706 ENDIF 707 DO ji = startloop, nlci 708 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 709 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 710 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 711 END DO 712 IF (nimpp .eq. 1) THEN 713 pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) 714 ENDIF 715 ! 716 CASE ( 'F' ) ! F-point 717 IF( nimpp + nlci - 1 /= jpiglo ) THEN 718 endloop = nlci 719 ELSE 720 endloop = nlci - 1 721 ENDIF 722 DO ji = 1, endloop 723 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 724 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 725 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 726 END DO 727 IF (nimpp .eq. 1) THEN 728 pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3) 729 pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2) 730 ENDIF 731 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 732 pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3) 733 pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 734 ENDIF 735 ! 736 CASE ( 'I' ) ! ice U-V point (I-point) 737 IF( nimpp /= 1 ) THEN 738 startloop = 1 739 ELSE 740 startloop = 3 741 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 742 ENDIF 743 DO ji = startloop, nlci 744 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 745 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 746 END DO 747 ! 748 END SELECT 749 ! 750 CASE ( 5, 6 ) ! * North fold F-point pivot 751 ! 752 SELECT CASE ( cd_type ) 753 CASE ( 'T' , 'W' ) ! T-, W-point 754 DO ji = 1, nlci 755 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 756 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 757 END DO 758 ! 759 CASE ( 'U' ) ! U-point 760 IF( nimpp + nlci - 1 /= jpiglo ) THEN 761 endloop = nlci 762 ELSE 763 endloop = nlci - 1 764 ENDIF 765 DO ji = 1, endloop 766 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 767 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 768 END DO 769 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 770 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 771 ENDIF 772 ! 773 CASE ( 'V' ) ! V-point 774 DO ji = 1, nlci 775 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 776 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 777 END DO 778 IF( nimpp >= jpiglo/2+1 ) THEN 779 startloop = 1 780 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 781 startloop = jpiglo/2+1 - nimpp + 1 782 ELSE 783 startloop = nlci + 1 784 ENDIF 785 DO ji = startloop, nlci 786 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 787 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 788 END DO 789 ! 790 CASE ( 'F' ) ! F-point 791 IF( nimpp + nlci - 1 /= jpiglo ) THEN 792 endloop = nlci 793 ELSE 794 endloop = nlci - 1 795 ENDIF 796 DO ji = 1, endloop 797 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 798 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 799 END DO 800 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 801 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 802 ENDIF 803 ! 804 IF( nimpp + nlci - 1 /= jpiglo ) THEN 805 endloop = nlci 806 ELSE 807 endloop = nlci - 1 808 ENDIF 809 IF( nimpp >= jpiglo/2+1 ) THEN 810 startloop = 1 811 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 812 startloop = jpiglo/2+1 - nimpp + 1 813 ELSE 814 startloop = endloop + 1 815 ENDIF 816 ! 817 DO ji = startloop, endloop 818 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 819 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 820 END DO 821 ! 822 CASE ( 'I' ) ! ice U-V point (I-point) 823 IF( nimpp /= 1 ) THEN 824 startloop = 1 825 ELSE 826 startloop = 2 827 ENDIF 828 IF( nimpp + nlci - 1 /= jpiglo ) THEN 829 endloop = nlci 830 ELSE 831 endloop = nlci - 1 832 ENDIF 833 DO ji = startloop , endloop 834 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 835 pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 836 END DO 837 ! 838 END SELECT 839 ! 840 CASE DEFAULT ! * closed : the code probably never go through 841 ! 842 SELECT CASE ( cd_type) 843 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 844 pt2dl(:, 1 ) = 0._wp 845 pt2dl(:,ijpj) = 0._wp 846 CASE ( 'F' ) ! F-point 847 pt2dl(:,ijpj) = 0._wp 848 CASE ( 'I' ) ! ice U-V point 849 pt2dl(:, 1 ) = 0._wp 850 pt2dl(:,ijpj) = 0._wp 851 END SELECT 852 ! 853 END SELECT 854 ! 855 END SUBROUTINE mpp_lbc_nfd_2d 277 END SUBROUTINE lbc_nfd_2d_org 856 278 857 279 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
