Changeset 3680 for branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC
- Timestamp:
- 2012-11-27T15:42:24+01:00 (11 years ago)
- Location:
- branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC
- Files:
-
- 2 edited
-
lbclnk.F90 (modified) (7 diffs)
-
lib_mpp.F90 (modified) (24 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r3609 r3680 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'lbc_bdy_lnk' 10 !! and lbc_obc_lnk' routine to optimize 11 !! the BDY/OBC communications 9 12 !!---------------------------------------------------------------------- 10 13 #if defined key_mpp_mpi … … 14 17 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 15 18 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 19 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 20 !! lbc_obc_lnk : generic interface for mpp_lnk_obc_2d and mpp_lnk_obc_3d routines defined in lib_mpp 16 21 !!---------------------------------------------------------------------- 17 22 USE lib_mpp ! distributed memory computing library … … 21 26 END INTERFACE 22 27 28 INTERFACE lbc_bdy_lnk 29 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 30 END INTERFACE 31 INTERFACE lbc_obc_lnk 32 MODULE PROCEDURE mpp_lnk_obc_2d, mpp_lnk_obc_3d 33 END INTERFACE 34 23 35 INTERFACE lbc_lnk_e 24 36 MODULE PROCEDURE mpp_lnk_2d_e … … 27 39 PUBLIC lbc_lnk ! ocean lateral boundary conditions 28 40 PUBLIC lbc_lnk_e 41 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 42 PUBLIC lbc_obc_lnk ! ocean lateral BDY boundary conditions 29 43 30 44 !!---------------------------------------------------------------------- … … 41 55 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh 42 56 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh 57 !! lbc_bdy_lnk : set the lateral BDY boundary condition 58 !! lbc_obc_lnk : set the lateral OBC boundary condition 43 59 !!---------------------------------------------------------------------- 44 60 USE oce ! ocean dynamics and tracers … … 58 74 END INTERFACE 59 75 76 INTERFACE lbc_bdy_lnk 77 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 78 END INTERFACE 79 INTERFACE lbc_obc_lnk 80 MODULE PROCEDURE lbc_lnk_2d, lbc_lnk_3d 81 END INTERFACE 82 60 83 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 61 84 PUBLIC lbc_lnk_e 85 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 86 PUBLIC lbc_obc_lnk ! ocean lateral OBC boundary conditions 62 87 63 88 !!---------------------------------------------------------------------- … … 180 205 END SUBROUTINE lbc_lnk_3d 181 206 207 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 208 !!--------------------------------------------------------------------- 209 !! *** ROUTINE lbc_bdy_lnk *** 210 !! 211 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 212 !! to maintain the same interface with regards to the mpp case 213 !! 214 !!---------------------------------------------------------------------- 215 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 216 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 217 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 218 INTEGER :: ib_bdy ! BDY boundary set 219 !! 220 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 221 222 END SUBROUTINE lbc_bdy_lnk_3d 223 224 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 225 !!--------------------------------------------------------------------- 226 !! *** ROUTINE lbc_bdy_lnk *** 227 !! 228 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 229 !! to maintain the same interface with regards to the mpp case 230 !! 231 !!---------------------------------------------------------------------- 232 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 233 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 234 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 235 INTEGER :: ib_bdy ! BDY boundary set 236 !! 237 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 238 239 END SUBROUTINE lbc_bdy_lnk_2d 182 240 183 241 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) -
branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3632 r3680 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d', 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 !! the mppobc routine to optimize the BDY and OBC communications 21 24 !!---------------------------------------------------------------------- 22 25 … … 69 72 PUBLIC mppsend, mpprecv ! needed by ICB routines 70 73 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 74 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 75 PUBLIC mpp_lnk_obc_2d, mpp_lnk_obc_3d 71 76 72 77 !! * Interfaces … … 348 353 END FUNCTION mynode 349 354 350 351 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 352 !!---------------------------------------------------------------------- 353 !! *** routine mpp_lnk_3d *** 355 SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 356 !!---------------------------------------------------------------------- 357 !! *** routine mpp_lnk_obc_3d *** 354 358 !! 355 359 !! ** Purpose : Message passing manadgement 356 360 !! 357 !! ** Method : Use mppsend and mpprecv function for passing mask361 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 358 362 !! between processors following neighboring subdomains. 359 363 !! domain parameters … … 375 379 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 376 380 ! ! = 1. , the sign is kept 377 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only378 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)379 381 !! 380 382 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 385 387 !!---------------------------------------------------------------------- 386 388 387 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 388 ELSE ; zland = 0.e0 ! zero by default 389 ENDIF 389 zland = 0.e0 ! zero by default 390 390 391 391 ! 1. standard boundary treatment 392 392 ! ------------------------------ 393 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 394 ! 395 ! WARNING ptab is defined only between nld and nle 396 DO jk = 1, jpk 397 DO jj = nlcj+1, jpj ! added line(s) (inner only) 398 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 399 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 400 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 401 END DO 402 DO ji = nlci+1, jpi ! added column(s) (full) 403 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 404 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 405 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 406 END DO 407 END DO 408 ! 409 ELSE ! standard close or cyclic treatment 410 ! 411 ! ! East-West boundaries 412 ! !* Cyclic east-west 413 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 414 ptab( 1 ,:,:) = ptab(jpim1,:,:) 415 ptab(jpi,:,:) = ptab( 2 ,:,:) 416 ELSE !* closed 417 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 418 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 419 ENDIF 420 ! ! North-South boundaries (always closed) 421 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 422 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 423 ! 393 IF( nbondi == 2) THEN 394 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 395 ptab( 1 ,:,:) = ptab(jpim1,:,:) 396 ptab(jpi,:,:) = ptab( 2 ,:,:) 397 ELSE 398 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 399 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 400 ENDIF 401 ELSEIF(nbondi == -1) THEN 402 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 403 ELSEIF(nbondi == 1) THEN 404 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 405 ENDIF !* closed 406 407 IF (nbondj == 2 .OR. nbondj == -1) THEN 408 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 409 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 410 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 424 411 ENDIF 425 412 … … 428 415 ! we play with the neigbours AND the row number because of the periodicity 429 416 ! 417 IF(nbondj .ne. 0) THEN 430 418 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 431 419 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) … … 466 454 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 467 455 END DO 468 CASE ( 0 ) 456 CASE ( 0 ) 469 457 DO jl = 1, jpreci 470 458 ptab(jl ,:,:) = t3we(:,jl,:,2) … … 476 464 END DO 477 465 END SELECT 466 ENDIF 478 467 479 468 … … 482 471 ! always closed : we play only with the neigbours 483 472 ! 473 IF(nbondi .ne. 0) THEN 484 474 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 485 475 ijhom = nlcj-nrecj … … 519 509 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 520 510 END DO 521 CASE ( 0 ) 511 CASE ( 0 ) 522 512 DO jl = 1, jprecj 523 513 ptab(:,jl ,:) = t3sn(:,jl,:,2) … … 529 519 END DO 530 520 END SELECT 521 ENDIF 531 522 532 523 … … 534 525 ! ----------------------- 535 526 ! 536 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp)) THEN527 IF( npolj /= 0 ) THEN 537 528 ! 538 529 SELECT CASE ( jpni ) … … 543 534 ENDIF 544 535 ! 545 END SUBROUTINE mpp_lnk_ 3d546 547 548 SUBROUTINE mpp_lnk_ 2d( pt2d, cd_type, psgn, cd_mpp, pval)549 !!---------------------------------------------------------------------- 550 !! *** routine mpp_lnk_ 2d ***536 END SUBROUTINE mpp_lnk_obc_3d 537 538 539 SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 540 !!---------------------------------------------------------------------- 541 !! *** routine mpp_lnk_obc_2d *** 551 542 !! 552 543 !! ** Purpose : Message passing manadgement for 2d array 553 544 !! 554 !! ** Method : Use mppsend and mpprecv function for passing mask545 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 555 546 !! between processors following neighboring subdomains. 556 547 !! domain parameters … … 570 561 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 571 562 ! ! = 1. , the sign is kept 572 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only573 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)574 563 !! 575 564 INTEGER :: ji, jj, jl ! dummy loop indices … … 580 569 !!---------------------------------------------------------------------- 581 570 582 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 583 ELSE ; zland = 0.e0 ! zero by default 584 ENDIF 571 zland = 0.e0 ! zero by default 585 572 586 573 ! 1. standard boundary treatment 587 574 ! ------------------------------ 588 575 ! 589 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 590 ! 591 ! WARNING pt2d is defined only between nld and nle 592 DO jj = nlcj+1, jpj ! added line(s) (inner only) 593 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 594 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 595 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 596 END DO 597 DO ji = nlci+1, jpi ! added column(s) (full) 598 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 599 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 600 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 601 END DO 602 ! 603 ELSE ! standard close or cyclic treatment 604 ! 605 ! ! East-West boundaries 606 IF( nbondi == 2 .AND. & ! Cyclic east-west 607 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 608 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 609 pt2d(jpi,:) = pt2d( 2 ,:) ! east 610 ELSE ! closed 611 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 612 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 613 ENDIF 614 ! ! North-South boundaries (always closed) 615 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 616 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 617 ! 576 IF( nbondi == 2) THEN 577 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 578 pt2d( 1 ,:) = pt2d(jpim1,:) 579 pt2d(jpi,:) = pt2d( 2 ,:) 580 ELSE 581 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 582 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 583 ENDIF 584 ELSEIF(nbondi == -1) THEN 585 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 586 ELSEIF(nbondi == 1) THEN 587 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 588 ENDIF !* closed 589 590 IF (nbondj == 2 .OR. nbondj == -1) THEN 591 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland ! south except F-point 592 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 593 pt2d(:,nlcj-jprecj+1:jpj) = zland ! north 618 594 ENDIF 619 595 … … 728 704 ! ----------------------- 729 705 ! 706 IF( npolj /= 0 ) THEN 707 ! 708 SELECT CASE ( jpni ) 709 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 710 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 711 END SELECT 712 ! 713 ENDIF 714 ! 715 END SUBROUTINE mpp_lnk_obc_2d 716 717 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 718 !!---------------------------------------------------------------------- 719 !! *** routine mpp_lnk_3d *** 720 !! 721 !! ** Purpose : Message passing manadgement 722 !! 723 !! ** Method : Use mppsend and mpprecv function for passing mask 724 !! between processors following neighboring subdomains. 725 !! domain parameters 726 !! nlci : first dimension of the local subdomain 727 !! nlcj : second dimension of the local subdomain 728 !! nbondi : mark for "east-west local boundary" 729 !! nbondj : mark for "north-south local boundary" 730 !! noea : number for local neighboring processors 731 !! nowe : number for local neighboring processors 732 !! noso : number for local neighboring processors 733 !! nono : number for local neighboring processors 734 !! 735 !! ** Action : ptab with update value at its periphery 736 !! 737 !!---------------------------------------------------------------------- 738 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 739 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 740 ! ! = T , U , V , F , W points 741 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 742 ! ! = 1. , the sign is kept 743 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 744 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 745 !! 746 INTEGER :: ji, jj, jk, jl ! dummy loop indices 747 INTEGER :: imigr, iihom, ijhom ! temporary integers 748 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 749 REAL(wp) :: zland 750 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 751 !!---------------------------------------------------------------------- 752 753 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 754 ELSE ; zland = 0.e0 ! zero by default 755 ENDIF 756 757 ! 1. standard boundary treatment 758 ! ------------------------------ 759 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 760 ! 761 ! WARNING ptab is defined only between nld and nle 762 DO jk = 1, jpk 763 DO jj = nlcj+1, jpj ! added line(s) (inner only) 764 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 765 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 766 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 767 END DO 768 DO ji = nlci+1, jpi ! added column(s) (full) 769 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 770 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 771 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 772 END DO 773 END DO 774 ! 775 ELSE ! standard close or cyclic treatment 776 ! 777 ! ! East-West boundaries 778 ! !* Cyclic east-west 779 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 780 ptab( 1 ,:,:) = ptab(jpim1,:,:) 781 ptab(jpi,:,:) = ptab( 2 ,:,:) 782 ELSE !* closed 783 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 784 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 785 ENDIF 786 ! ! North-South boundaries (always closed) 787 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 788 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 789 ! 790 ENDIF 791 792 ! 2. East and west directions exchange 793 ! ------------------------------------ 794 ! we play with the neigbours AND the row number because of the periodicity 795 ! 796 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 797 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 798 iihom = nlci-nreci 799 DO jl = 1, jpreci 800 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 801 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 802 END DO 803 END SELECT 804 ! 805 ! ! Migrations 806 imigr = jpreci * jpj * jpk 807 ! 808 SELECT CASE ( nbondi ) 809 CASE ( -1 ) 810 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 811 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 812 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 813 CASE ( 0 ) 814 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 815 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 816 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 817 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 818 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 819 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 820 CASE ( 1 ) 821 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 822 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 823 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 824 END SELECT 825 ! 826 ! ! Write Dirichlet lateral conditions 827 iihom = nlci-jpreci 828 ! 829 SELECT CASE ( nbondi ) 830 CASE ( -1 ) 831 DO jl = 1, jpreci 832 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 833 END DO 834 CASE ( 0 ) 835 DO jl = 1, jpreci 836 ptab(jl ,:,:) = t3we(:,jl,:,2) 837 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 838 END DO 839 CASE ( 1 ) 840 DO jl = 1, jpreci 841 ptab(jl ,:,:) = t3we(:,jl,:,2) 842 END DO 843 END SELECT 844 845 846 ! 3. North and south directions 847 ! ----------------------------- 848 ! always closed : we play only with the neigbours 849 ! 850 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 851 ijhom = nlcj-nrecj 852 DO jl = 1, jprecj 853 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 854 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 855 END DO 856 ENDIF 857 ! 858 ! ! Migrations 859 imigr = jprecj * jpi * jpk 860 ! 861 SELECT CASE ( nbondj ) 862 CASE ( -1 ) 863 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 864 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 865 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 866 CASE ( 0 ) 867 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 868 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 869 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 870 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 871 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 872 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 873 CASE ( 1 ) 874 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 875 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 876 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 877 END SELECT 878 ! 879 ! ! Write Dirichlet lateral conditions 880 ijhom = nlcj-jprecj 881 ! 882 SELECT CASE ( nbondj ) 883 CASE ( -1 ) 884 DO jl = 1, jprecj 885 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 886 END DO 887 CASE ( 0 ) 888 DO jl = 1, jprecj 889 ptab(:,jl ,:) = t3sn(:,jl,:,2) 890 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 891 END DO 892 CASE ( 1 ) 893 DO jl = 1, jprecj 894 ptab(:,jl,:) = t3sn(:,jl,:,2) 895 END DO 896 END SELECT 897 898 899 ! 4. north fold treatment 900 ! ----------------------- 901 ! 902 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 903 ! 904 SELECT CASE ( jpni ) 905 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 906 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 907 END SELECT 908 ! 909 ENDIF 910 ! 911 END SUBROUTINE mpp_lnk_3d 912 913 914 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 915 !!---------------------------------------------------------------------- 916 !! *** routine mpp_lnk_2d *** 917 !! 918 !! ** Purpose : Message passing manadgement for 2d array 919 !! 920 !! ** Method : Use mppsend and mpprecv function for passing mask 921 !! between processors following neighboring subdomains. 922 !! domain parameters 923 !! nlci : first dimension of the local subdomain 924 !! nlcj : second dimension of the local subdomain 925 !! nbondi : mark for "east-west local boundary" 926 !! nbondj : mark for "north-south local boundary" 927 !! noea : number for local neighboring processors 928 !! nowe : number for local neighboring processors 929 !! noso : number for local neighboring processors 930 !! nono : number for local neighboring processors 931 !! 932 !!---------------------------------------------------------------------- 933 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 934 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 935 ! ! = T , U , V , F , W and I points 936 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 937 ! ! = 1. , the sign is kept 938 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 939 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 940 !! 941 INTEGER :: ji, jj, jl ! dummy loop indices 942 INTEGER :: imigr, iihom, ijhom ! temporary integers 943 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 944 REAL(wp) :: zland 945 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 946 !!---------------------------------------------------------------------- 947 948 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 949 ELSE ; zland = 0.e0 ! zero by default 950 ENDIF 951 952 ! 1. standard boundary treatment 953 ! ------------------------------ 954 ! 955 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 956 ! 957 ! WARNING pt2d is defined only between nld and nle 958 DO jj = nlcj+1, jpj ! added line(s) (inner only) 959 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 960 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 961 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 962 END DO 963 DO ji = nlci+1, jpi ! added column(s) (full) 964 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 965 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 966 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 967 END DO 968 ! 969 ELSE ! standard close or cyclic treatment 970 ! 971 ! ! East-West boundaries 972 IF( nbondi == 2 .AND. & ! Cyclic east-west 973 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 974 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 975 pt2d(jpi,:) = pt2d( 2 ,:) ! east 976 ELSE ! closed 977 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 978 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 979 ENDIF 980 ! ! North-South boundaries (always closed) 981 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 982 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 983 ! 984 ENDIF 985 986 ! 2. East and west directions exchange 987 ! ------------------------------------ 988 ! we play with the neigbours AND the row number because of the periodicity 989 ! 990 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 991 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 992 iihom = nlci-nreci 993 DO jl = 1, jpreci 994 t2ew(:,jl,1) = pt2d(jpreci+jl,:) 995 t2we(:,jl,1) = pt2d(iihom +jl,:) 996 END DO 997 END SELECT 998 ! 999 ! ! Migrations 1000 imigr = jpreci * jpj 1001 ! 1002 SELECT CASE ( nbondi ) 1003 CASE ( -1 ) 1004 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 1005 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1006 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1007 CASE ( 0 ) 1008 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1009 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 1010 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1011 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1012 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1013 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1014 CASE ( 1 ) 1015 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1016 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1017 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1018 END SELECT 1019 ! 1020 ! ! Write Dirichlet lateral conditions 1021 iihom = nlci - jpreci 1022 ! 1023 SELECT CASE ( nbondi ) 1024 CASE ( -1 ) 1025 DO jl = 1, jpreci 1026 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1027 END DO 1028 CASE ( 0 ) 1029 DO jl = 1, jpreci 1030 pt2d(jl ,:) = t2we(:,jl,2) 1031 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1032 END DO 1033 CASE ( 1 ) 1034 DO jl = 1, jpreci 1035 pt2d(jl ,:) = t2we(:,jl,2) 1036 END DO 1037 END SELECT 1038 1039 1040 ! 3. North and south directions 1041 ! ----------------------------- 1042 ! always closed : we play only with the neigbours 1043 ! 1044 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1045 ijhom = nlcj-nrecj 1046 DO jl = 1, jprecj 1047 t2sn(:,jl,1) = pt2d(:,ijhom +jl) 1048 t2ns(:,jl,1) = pt2d(:,jprecj+jl) 1049 END DO 1050 ENDIF 1051 ! 1052 ! ! Migrations 1053 imigr = jprecj * jpi 1054 ! 1055 SELECT CASE ( nbondj ) 1056 CASE ( -1 ) 1057 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 1058 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1059 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1060 CASE ( 0 ) 1061 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1062 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 1063 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1064 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1065 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1066 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1067 CASE ( 1 ) 1068 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1069 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1070 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1071 END SELECT 1072 ! 1073 ! ! Write Dirichlet lateral conditions 1074 ijhom = nlcj - jprecj 1075 ! 1076 SELECT CASE ( nbondj ) 1077 CASE ( -1 ) 1078 DO jl = 1, jprecj 1079 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1080 END DO 1081 CASE ( 0 ) 1082 DO jl = 1, jprecj 1083 pt2d(:,jl ) = t2sn(:,jl,2) 1084 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1085 END DO 1086 CASE ( 1 ) 1087 DO jl = 1, jprecj 1088 pt2d(:,jl ) = t2sn(:,jl,2) 1089 END DO 1090 END SELECT 1091 1092 1093 ! 4. north fold treatment 1094 ! ----------------------- 1095 ! 730 1096 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 731 1097 ! … … 1782 2148 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1783 2149 REAL(wp), POINTER, DIMENSION(:,:) :: ztab ! temporary workspace 2150 LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 1784 2151 !!---------------------------------------------------------------------- 1785 2152 … … 1807 2174 CALL mppstop 1808 2175 ENDIF 1809 2176 1810 2177 ! Communication level by level 1811 2178 ! ---------------------------- 1812 2179 !!gm Remark : this is very time consumming!!! 1813 2180 ! ! ------------------------ ! 2181 IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 2182 ! there is nothing to be migrated 2183 lmigr = .FALSE. 2184 ELSE 2185 lmigr = .TRUE. 2186 ENDIF 2187 2188 IF( lmigr ) THEN 2189 1814 2190 DO jk = 1, kk ! Loop over the levels ! 1815 2191 ! ! ------------------------ ! … … 1833 2209 ! --------------------------- 1834 2210 ! 2211 IF( ktype == 1 ) THEN 2212 1835 2213 IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions 1836 2214 iihom = nlci-nreci 1837 DO jl = 1, jpreci 1838 t2ew(:,jl,1) = ztab(jpreci+jl,:) 1839 t2we(:,jl,1) = ztab(iihom +jl,:) 1840 END DO 2215 t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 2216 t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 1841 2217 ENDIF 1842 2218 ! 1843 2219 ! ! Migrations 1844 imigr =jpreci*jpj2220 imigr = jpreci 1845 2221 ! 1846 2222 IF( nbondi == -1 ) THEN … … 1865 2241 ! 1866 2242 IF( nbondi == 0 .OR. nbondi == 1 ) THEN 1867 DO jl = 1, jpreci 1868 ztab(jl,:) = t2we(:,jl,2) 1869 END DO 2243 ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 1870 2244 ENDIF 1871 2245 IF( nbondi == -1 .OR. nbondi == 0 ) THEN 1872 DO jl = 1, jpreci 1873 ztab(iihom+jl,:) = t2ew(:,jl,2) 1874 END DO 2246 ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 1875 2247 ENDIF 1876 2248 ENDIF ! (ktype == 1) 1877 2249 1878 2250 ! 2. North and south directions 1879 2251 ! ----------------------------- 1880 2252 ! 2253 IF(ktype == 2 ) THEN 1881 2254 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1882 2255 ijhom = nlcj-nrecj 1883 DO jl = 1, jprecj 1884 t2sn(:,jl,1) = ztab(:,ijhom +jl) 1885 t2ns(:,jl,1) = ztab(:,jprecj+jl) 1886 END DO 2256 t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 2257 t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 1887 2258 ENDIF 1888 2259 ! 1889 2260 ! ! Migrations 1890 imigr = jprecj * jpi2261 imigr = jprecj 1891 2262 ! 1892 2263 IF( nbondj == -1 ) THEN … … 1910 2281 ijhom = nlcj - jprecj 1911 2282 IF( nbondj == 0 .OR. nbondj == 1 ) THEN 1912 DO jl = 1, jprecj 1913 ztab(:,jl) = t2sn(:,jl,2) 1914 END DO 2283 ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 1915 2284 ENDIF 1916 2285 IF( nbondj == 0 .OR. nbondj == -1 ) THEN 1917 DO jl = 1, jprecj 1918 ztab(:,ijhom+jl) = t2ns(:,jl,2) 1919 END DO 2286 ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 1920 2287 ENDIF 2288 ENDIF ! (ktype == 2) 1921 2289 IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 1922 2290 DO jj = ijpt0, ijpt1 ! north/south boundaries 1923 2291 DO ji = iipt0,ilpt1 1924 ptab(ji,jk) = ztab(ji,jj) 2292 ptab(ji,jk) = ztab(ji,jj) 1925 2293 END DO 1926 2294 END DO … … 1928 2296 DO jj = ijpt0, ilpt1 ! east/west boundaries 1929 2297 DO ji = iipt0,iipt1 1930 ptab(jj,jk) = ztab(ji,jj) 2298 ptab(jj,jk) = ztab(ji,jj) 1931 2299 END DO 1932 2300 END DO … … 1935 2303 END DO 1936 2304 ! 2305 ENDIF ! ( lmigr ) 1937 2306 CALL wrk_dealloc( jpi,jpj, ztab ) 1938 2307 ! … … 2534 2903 END SUBROUTINE mpp_lbc_north_e 2535 2904 2905 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2906 !!---------------------------------------------------------------------- 2907 !! *** routine mpp_lnk_bdy_3d *** 2908 !! 2909 !! ** Purpose : Message passing management 2910 !! 2911 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 2912 !! between processors following neighboring subdomains. 2913 !! domain parameters 2914 !! nlci : first dimension of the local subdomain 2915 !! nlcj : second dimension of the local subdomain 2916 !! nbondi_bdy : mark for "east-west local boundary" 2917 !! nbondj_bdy : mark for "north-south local boundary" 2918 !! noea : number for local neighboring processors 2919 !! nowe : number for local neighboring processors 2920 !! noso : number for local neighboring processors 2921 !! nono : number for local neighboring processors 2922 !! 2923 !! ** Action : ptab with update value at its periphery 2924 !! 2925 !!---------------------------------------------------------------------- 2926 2927 USE lbcnfd ! north fold 2928 2929 INCLUDE 'mpif.h' 2930 2931 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2932 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2933 ! ! = T , U , V , F , W points 2934 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2935 ! ! = 1. , the sign is kept 2936 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2937 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2938 INTEGER :: imigr, iihom, ijhom ! temporary integers 2939 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2940 REAL(wp) :: zland 2941 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2942 !!---------------------------------------------------------------------- 2943 2944 zland = 0.e0 2945 2946 ! 1. standard boundary treatment 2947 ! ------------------------------ 2948 2949 ! ! East-West boundaries 2950 ! !* Cyclic east-west 2951 2952 IF( nbondi == 2) THEN 2953 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2954 ptab( 1 ,:,:) = ptab(jpim1,:,:) 2955 ptab(jpi,:,:) = ptab( 2 ,:,:) 2956 ELSE 2957 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2958 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2959 ENDIF 2960 ELSEIF(nbondi == -1) THEN 2961 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2962 ELSEIF(nbondi == 1) THEN 2963 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2964 ENDIF !* closed 2965 2966 IF (nbondj == 2 .OR. nbondj == -1) THEN 2967 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 2968 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2969 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2970 ENDIF 2971 2972 ! 2973 2974 ! 2. East and west directions exchange 2975 ! ------------------------------------ 2976 ! we play with the neigbours AND the row number because of the periodicity 2977 ! 2978 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 2979 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 2980 iihom = nlci-nreci 2981 DO jl = 1, jpreci 2982 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 2983 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 2984 END DO 2985 END SELECT 2986 ! 2987 ! ! Migrations 2988 imigr = jpreci * jpj * jpk 2989 ! 2990 SELECT CASE ( nbondi_bdy(ib_bdy) ) 2991 CASE ( -1 ) 2992 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 2993 CASE ( 0 ) 2994 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 2995 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 2996 CASE ( 1 ) 2997 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 2998 END SELECT 2999 ! 3000 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3001 CASE ( -1 ) 3002 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3003 CASE ( 0 ) 3004 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3005 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3006 CASE ( 1 ) 3007 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3008 END SELECT 3009 ! 3010 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3011 CASE ( -1 ) 3012 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3013 CASE ( 0 ) 3014 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3015 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3016 CASE ( 1 ) 3017 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3018 END SELECT 3019 ! 3020 ! ! Write Dirichlet lateral conditions 3021 iihom = nlci-jpreci 3022 ! 3023 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3024 CASE ( -1 ) 3025 DO jl = 1, jpreci 3026 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3027 END DO 3028 CASE ( 0 ) 3029 DO jl = 1, jpreci 3030 ptab(jl ,:,:) = t3we(:,jl,:,2) 3031 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3032 END DO 3033 CASE ( 1 ) 3034 DO jl = 1, jpreci 3035 ptab(jl ,:,:) = t3we(:,jl,:,2) 3036 END DO 3037 END SELECT 3038 3039 3040 ! 3. North and south directions 3041 ! ----------------------------- 3042 ! always closed : we play only with the neigbours 3043 ! 3044 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3045 ijhom = nlcj-nrecj 3046 DO jl = 1, jprecj 3047 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 3048 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 3049 END DO 3050 ENDIF 3051 ! 3052 ! ! Migrations 3053 imigr = jprecj * jpi * jpk 3054 ! 3055 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3056 CASE ( -1 ) 3057 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 3058 CASE ( 0 ) 3059 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3060 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 3061 CASE ( 1 ) 3062 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3063 END SELECT 3064 ! 3065 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3066 CASE ( -1 ) 3067 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3068 CASE ( 0 ) 3069 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3070 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3071 CASE ( 1 ) 3072 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3073 END SELECT 3074 ! 3075 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3076 CASE ( -1 ) 3077 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3078 CASE ( 0 ) 3079 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3080 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3081 CASE ( 1 ) 3082 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3083 END SELECT 3084 ! 3085 ! ! Write Dirichlet lateral conditions 3086 ijhom = nlcj-jprecj 3087 ! 3088 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3089 CASE ( -1 ) 3090 DO jl = 1, jprecj 3091 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3092 END DO 3093 CASE ( 0 ) 3094 DO jl = 1, jprecj 3095 ptab(:,jl ,:) = t3sn(:,jl,:,2) 3096 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3097 END DO 3098 CASE ( 1 ) 3099 DO jl = 1, jprecj 3100 ptab(:,jl,:) = t3sn(:,jl,:,2) 3101 END DO 3102 END SELECT 3103 3104 3105 ! 4. north fold treatment 3106 ! ----------------------- 3107 ! 3108 IF( npolj /= 0) THEN 3109 ! 3110 SELECT CASE ( jpni ) 3111 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3112 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3113 END SELECT 3114 ! 3115 ENDIF 3116 ! 3117 END SUBROUTINE mpp_lnk_bdy_3d 3118 3119 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3120 !!---------------------------------------------------------------------- 3121 !! *** routine mpp_lnk_bdy_2d *** 3122 !! 3123 !! ** Purpose : Message passing management 3124 !! 3125 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 3126 !! between processors following neighboring subdomains. 3127 !! domain parameters 3128 !! nlci : first dimension of the local subdomain 3129 !! nlcj : second dimension of the local subdomain 3130 !! nbondi_bdy : mark for "east-west local boundary" 3131 !! nbondj_bdy : mark for "north-south local boundary" 3132 !! noea : number for local neighboring processors 3133 !! nowe : number for local neighboring processors 3134 !! noso : number for local neighboring processors 3135 !! nono : number for local neighboring processors 3136 !! 3137 !! ** Action : ptab with update value at its periphery 3138 !! 3139 !!---------------------------------------------------------------------- 3140 3141 USE lbcnfd ! north fold 3142 3143 INCLUDE 'mpif.h' 3144 3145 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3146 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3147 ! ! = T , U , V , F , W points 3148 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3149 ! ! = 1. , the sign is kept 3150 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3151 INTEGER :: ji, jj, jl ! dummy loop indices 3152 INTEGER :: imigr, iihom, ijhom ! temporary integers 3153 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3154 REAL(wp) :: zland 3155 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3156 !!---------------------------------------------------------------------- 3157 3158 zland = 0.e0 3159 3160 ! 1. standard boundary treatment 3161 ! ------------------------------ 3162 3163 ! ! East-West boundaries 3164 ! !* Cyclic east-west 3165 3166 IF( nbondi == 2) THEN 3167 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3168 ptab( 1 ,:) = ptab(jpim1,:) 3169 ptab(jpi,:) = ptab( 2 ,:) 3170 ELSE 3171 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3172 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3173 ENDIF 3174 ELSEIF(nbondi == -1) THEN 3175 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3176 ELSEIF(nbondi == 1) THEN 3177 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3178 ENDIF !* closed 3179 3180 IF (nbondj == 2 .OR. nbondj == -1) THEN 3181 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 3182 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 3183 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 3184 ENDIF 3185 3186 ! 3187 3188 ! 2. East and west directions exchange 3189 ! ------------------------------------ 3190 ! we play with the neigbours AND the row number because of the periodicity 3191 ! 3192 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 3193 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3194 iihom = nlci-nreci 3195 DO jl = 1, jpreci 3196 t2ew(:,jl,1) = ptab(jpreci+jl,:) 3197 t2we(:,jl,1) = ptab(iihom +jl,:) 3198 END DO 3199 END SELECT 3200 ! 3201 ! ! Migrations 3202 imigr = jpreci * jpj 3203 ! 3204 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3205 CASE ( -1 ) 3206 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 3207 CASE ( 0 ) 3208 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3209 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 3210 CASE ( 1 ) 3211 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3212 END SELECT 3213 ! 3214 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3215 CASE ( -1 ) 3216 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3217 CASE ( 0 ) 3218 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3219 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3220 CASE ( 1 ) 3221 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3222 END SELECT 3223 ! 3224 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3225 CASE ( -1 ) 3226 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3227 CASE ( 0 ) 3228 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3229 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3230 CASE ( 1 ) 3231 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3232 END SELECT 3233 ! 3234 ! ! Write Dirichlet lateral conditions 3235 iihom = nlci-jpreci 3236 ! 3237 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3238 CASE ( -1 ) 3239 DO jl = 1, jpreci 3240 ptab(iihom+jl,:) = t2ew(:,jl,2) 3241 END DO 3242 CASE ( 0 ) 3243 DO jl = 1, jpreci 3244 ptab(jl ,:) = t2we(:,jl,2) 3245 ptab(iihom+jl,:) = t2ew(:,jl,2) 3246 END DO 3247 CASE ( 1 ) 3248 DO jl = 1, jpreci 3249 ptab(jl ,:) = t2we(:,jl,2) 3250 END DO 3251 END SELECT 3252 3253 3254 ! 3. North and south directions 3255 ! ----------------------------- 3256 ! always closed : we play only with the neigbours 3257 ! 3258 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3259 ijhom = nlcj-nrecj 3260 DO jl = 1, jprecj 3261 t2sn(:,jl,1) = ptab(:,ijhom +jl) 3262 t2ns(:,jl,1) = ptab(:,jprecj+jl) 3263 END DO 3264 ENDIF 3265 ! 3266 ! ! Migrations 3267 imigr = jprecj * jpi 3268 ! 3269 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3270 CASE ( -1 ) 3271 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 3272 CASE ( 0 ) 3273 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3274 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 3275 CASE ( 1 ) 3276 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3277 END SELECT 3278 ! 3279 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3280 CASE ( -1 ) 3281 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3282 CASE ( 0 ) 3283 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3284 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3285 CASE ( 1 ) 3286 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3287 END SELECT 3288 ! 3289 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3290 CASE ( -1 ) 3291 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3292 CASE ( 0 ) 3293 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3294 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3295 CASE ( 1 ) 3296 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3297 END SELECT 3298 ! 3299 ! ! Write Dirichlet lateral conditions 3300 ijhom = nlcj-jprecj 3301 ! 3302 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3303 CASE ( -1 ) 3304 DO jl = 1, jprecj 3305 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3306 END DO 3307 CASE ( 0 ) 3308 DO jl = 1, jprecj 3309 ptab(:,jl ) = t2sn(:,jl,2) 3310 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3311 END DO 3312 CASE ( 1 ) 3313 DO jl = 1, jprecj 3314 ptab(:,jl) = t2sn(:,jl,2) 3315 END DO 3316 END SELECT 3317 3318 3319 ! 4. north fold treatment 3320 ! ----------------------- 3321 ! 3322 IF( npolj /= 0) THEN 3323 ! 3324 SELECT CASE ( jpni ) 3325 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3326 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3327 END SELECT 3328 ! 3329 ENDIF 3330 ! 3331 END SUBROUTINE mpp_lnk_bdy_2d 2536 3332 2537 3333 SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
Note: See TracChangeset
for help on using the changeset viewer.
