New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 3646 for branches/2012/dev_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2012-11-24T14:47:12+01:00 (11 years ago)
Author:
vichi
Message:

Add the resulting merged branch from CMCC and INGV 2012 developments

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r3435 r3646  
    1919   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl  
    2020   !!            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 
    2124   !!---------------------------------------------------------------------- 
    2225 
     
    6871   PUBLIC   mppsize 
    6972   PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90 
     73   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
     74   PUBLIC   mpp_lnk_obc_2d, mpp_lnk_obc_3d 
    7075 
    7176   !! * Interfaces 
     
    354359   END FUNCTION mynode 
    355360 
    356  
    357    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    358       !!---------------------------------------------------------------------- 
    359       !!                  ***  routine mpp_lnk_3d  *** 
     361   SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 
     362      !!---------------------------------------------------------------------- 
     363      !!                  ***  routine mpp_lnk_obc_3d  *** 
    360364      !! 
    361365      !! ** Purpose :   Message passing manadgement 
    362366      !! 
    363       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     367      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    364368      !!      between processors following neighboring subdomains. 
    365369      !!            domain parameters 
     
    381385      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    382386      !                                                             ! =  1. , the sign is kept 
    383       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    384       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    385387      !! 
    386388      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     
    391393      !!---------------------------------------------------------------------- 
    392394 
    393       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    394       ELSE                         ;   zland = 0.e0      ! zero by default 
    395       ENDIF 
     395      zland = 0.e0      ! zero by default 
    396396 
    397397      ! 1. standard boundary treatment 
    398398      ! ------------------------------ 
    399       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    400          ! 
    401          ! WARNING ptab is defined only between nld and nle 
    402          DO jk = 1, jpk 
    403             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    404                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
    405                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    406                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    407             END DO 
    408             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    409                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    410                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    411                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    412             END DO 
    413          END DO 
    414          ! 
    415       ELSE                              ! standard close or cyclic treatment  
    416          ! 
    417          !                                   ! East-West boundaries 
    418          !                                        !* Cyclic east-west 
    419          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    420             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    421             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    422          ELSE                                     !* closed 
    423             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    424                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    425          ENDIF 
    426          !                                   ! North-South boundaries (always closed) 
    427          IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    428                                       ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    429          ! 
     399      IF( nbondi == 2) THEN 
     400        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     401          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     402          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     403        ELSE 
     404          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     405          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     406        ENDIF 
     407      ELSEIF(nbondi == -1) THEN 
     408        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     409      ELSEIF(nbondi == 1) THEN 
     410        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     411      ENDIF                                     !* closed 
     412 
     413      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     414        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     415      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     416        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    430417      ENDIF 
    431418 
     
    434421      ! we play with the neigbours AND the row number because of the periodicity  
    435422      ! 
     423      IF(nbondj .ne. 0) THEN 
    436424      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    437425      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     
    472460            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    473461         END DO 
    474       CASE ( 0 )  
     462      CASE ( 0 ) 
    475463         DO jl = 1, jpreci 
    476464            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     
    482470         END DO 
    483471      END SELECT 
     472      ENDIF 
    484473 
    485474 
     
    488477      ! always closed : we play only with the neigbours 
    489478      ! 
     479      IF(nbondi .ne. 0) THEN 
    490480      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    491481         ijhom = nlcj-nrecj 
     
    525515            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    526516         END DO 
    527       CASE ( 0 )  
     517      CASE ( 0 ) 
    528518         DO jl = 1, jprecj 
    529519            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     
    535525         END DO 
    536526      END SELECT 
     527      ENDIF 
    537528 
    538529 
     
    540531      ! ----------------------- 
    541532      ! 
    542       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     533      IF( npolj /= 0 ) THEN 
    543534         ! 
    544535         SELECT CASE ( jpni ) 
     
    549540      ENDIF 
    550541      ! 
    551    END SUBROUTINE mpp_lnk_3d 
    552  
    553  
    554    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    555       !!---------------------------------------------------------------------- 
    556       !!                  ***  routine mpp_lnk_2d  *** 
     542   END SUBROUTINE mpp_lnk_obc_3d 
     543 
     544 
     545   SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 
     546      !!---------------------------------------------------------------------- 
     547      !!                  ***  routine mpp_lnk_obc_2d  *** 
    557548      !!                   
    558549      !! ** Purpose :   Message passing manadgement for 2d array 
    559550      !! 
    560       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     551      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    561552      !!      between processors following neighboring subdomains. 
    562553      !!            domain parameters 
     
    576567      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    577568      !                                                         ! =  1. , the sign is kept 
    578       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    579       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    580569      !! 
    581570      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     
    586575      !!---------------------------------------------------------------------- 
    587576 
    588       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    589       ELSE                         ;   zland = 0.e0      ! zero by default 
    590       ENDIF 
     577      zland = 0.e0      ! zero by default 
    591578 
    592579      ! 1. standard boundary treatment 
    593580      ! ------------------------------ 
    594581      ! 
    595       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    596          ! 
    597          ! WARNING pt2d is defined only between nld and nle 
    598          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    599             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
    600             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    601             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    602          END DO 
    603          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    604             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    605             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    606             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    607          END DO 
    608          ! 
    609       ELSE                              ! standard close or cyclic treatment  
    610          ! 
    611          !                                   ! East-West boundaries 
    612          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    613             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    614             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    615             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    616          ELSE                                     ! closed 
    617             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    618                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    619          ENDIF 
    620          !                                   ! North-South boundaries (always closed) 
    621             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    622                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    623          ! 
     582      IF( nbondi == 2) THEN 
     583        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     584          pt2d( 1 ,:) = pt2d(jpim1,:) 
     585          pt2d(jpi,:) = pt2d(  2  ,:) 
     586        ELSE 
     587          IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     588          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     589        ENDIF 
     590      ELSEIF(nbondi == -1) THEN 
     591        IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     592      ELSEIF(nbondi == 1) THEN 
     593        pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     594      ENDIF                                     !* closed 
     595 
     596      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     597        IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland       ! south except F-point 
     598      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     599        pt2d(:,nlcj-jprecj+1:jpj) = zland       ! north 
    624600      ENDIF 
    625601 
     
    734710      ! ----------------------- 
    735711      ! 
     712      IF( npolj /= 0 ) THEN 
     713         ! 
     714         SELECT CASE ( jpni ) 
     715         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     716         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
     717         END SELECT 
     718         ! 
     719      ENDIF 
     720      ! 
     721   END SUBROUTINE mpp_lnk_obc_2d 
     722 
     723   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     724      !!---------------------------------------------------------------------- 
     725      !!                  ***  routine mpp_lnk_3d  *** 
     726      !! 
     727      !! ** Purpose :   Message passing manadgement 
     728      !! 
     729      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     730      !!      between processors following neighboring subdomains. 
     731      !!            domain parameters 
     732      !!                    nlci   : first dimension of the local subdomain 
     733      !!                    nlcj   : second dimension of the local subdomain 
     734      !!                    nbondi : mark for "east-west local boundary" 
     735      !!                    nbondj : mark for "north-south local boundary" 
     736      !!                    noea   : number for local neighboring processors  
     737      !!                    nowe   : number for local neighboring processors 
     738      !!                    noso   : number for local neighboring processors 
     739      !!                    nono   : number for local neighboring processors 
     740      !! 
     741      !! ** Action  :   ptab with update value at its periphery 
     742      !! 
     743      !!---------------------------------------------------------------------- 
     744      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     745      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     746      !                                                             ! = T , U , V , F , W points 
     747      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     748      !                                                             ! =  1. , the sign is kept 
     749      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     750      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     751      !! 
     752      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     753      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     754      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     755      REAL(wp) ::   zland 
     756      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     757      !!---------------------------------------------------------------------- 
     758 
     759      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     760      ELSE                         ;   zland = 0.e0      ! zero by default 
     761      ENDIF 
     762 
     763      ! 1. standard boundary treatment 
     764      ! ------------------------------ 
     765      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     766         ! 
     767         ! WARNING ptab is defined only between nld and nle 
     768         DO jk = 1, jpk 
     769            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     770               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
     771               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
     772               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     773            END DO 
     774            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     775               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
     776               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
     777               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
     778            END DO 
     779         END DO 
     780         ! 
     781      ELSE                              ! standard close or cyclic treatment  
     782         ! 
     783         !                                   ! East-West boundaries 
     784         !                                        !* Cyclic east-west 
     785         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     786            ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     787            ptab(jpi,:,:) = ptab(  2  ,:,:) 
     788         ELSE                                     !* closed 
     789            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     790                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     791         ENDIF 
     792         !                                   ! North-South boundaries (always closed) 
     793         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     794                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     795         ! 
     796      ENDIF 
     797 
     798      ! 2. East and west directions exchange 
     799      ! ------------------------------------ 
     800      ! we play with the neigbours AND the row number because of the periodicity  
     801      ! 
     802      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     803      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     804         iihom = nlci-nreci 
     805         DO jl = 1, jpreci 
     806            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     807            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     808         END DO 
     809      END SELECT   
     810      ! 
     811      !                           ! Migrations 
     812      imigr = jpreci * jpj * jpk 
     813      ! 
     814      SELECT CASE ( nbondi )  
     815      CASE ( -1 ) 
     816         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     817         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     818         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     819      CASE ( 0 ) 
     820         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     821         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     822         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     823         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     824         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     825         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     826      CASE ( 1 ) 
     827         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     828         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     829         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     830      END SELECT 
     831      ! 
     832      !                           ! Write Dirichlet lateral conditions 
     833      iihom = nlci-jpreci 
     834      ! 
     835      SELECT CASE ( nbondi ) 
     836      CASE ( -1 ) 
     837         DO jl = 1, jpreci 
     838            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     839         END DO 
     840      CASE ( 0 )  
     841         DO jl = 1, jpreci 
     842            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     843            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     844         END DO 
     845      CASE ( 1 ) 
     846         DO jl = 1, jpreci 
     847            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     848         END DO 
     849      END SELECT 
     850 
     851 
     852      ! 3. North and south directions 
     853      ! ----------------------------- 
     854      ! always closed : we play only with the neigbours 
     855      ! 
     856      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     857         ijhom = nlcj-nrecj 
     858         DO jl = 1, jprecj 
     859            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     860            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     861         END DO 
     862      ENDIF 
     863      ! 
     864      !                           ! Migrations 
     865      imigr = jprecj * jpi * jpk 
     866      ! 
     867      SELECT CASE ( nbondj )      
     868      CASE ( -1 ) 
     869         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     870         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     871         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     872      CASE ( 0 ) 
     873         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     874         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     875         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     876         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     877         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     878         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     879      CASE ( 1 )  
     880         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     881         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     882         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     883      END SELECT 
     884      ! 
     885      !                           ! Write Dirichlet lateral conditions 
     886      ijhom = nlcj-jprecj 
     887      ! 
     888      SELECT CASE ( nbondj ) 
     889      CASE ( -1 ) 
     890         DO jl = 1, jprecj 
     891            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     892         END DO 
     893      CASE ( 0 )  
     894         DO jl = 1, jprecj 
     895            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     896            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     897         END DO 
     898      CASE ( 1 ) 
     899         DO jl = 1, jprecj 
     900            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     901         END DO 
     902      END SELECT 
     903 
     904 
     905      ! 4. north fold treatment 
     906      ! ----------------------- 
     907      ! 
     908      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     909         ! 
     910         SELECT CASE ( jpni ) 
     911         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     912         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     913         END SELECT 
     914         ! 
     915      ENDIF 
     916      ! 
     917   END SUBROUTINE mpp_lnk_3d 
     918 
     919 
     920   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     921      !!---------------------------------------------------------------------- 
     922      !!                  ***  routine mpp_lnk_2d  *** 
     923      !!                   
     924      !! ** Purpose :   Message passing manadgement for 2d array 
     925      !! 
     926      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     927      !!      between processors following neighboring subdomains. 
     928      !!            domain parameters 
     929      !!                    nlci   : first dimension of the local subdomain 
     930      !!                    nlcj   : second dimension of the local subdomain 
     931      !!                    nbondi : mark for "east-west local boundary" 
     932      !!                    nbondj : mark for "north-south local boundary" 
     933      !!                    noea   : number for local neighboring processors  
     934      !!                    nowe   : number for local neighboring processors 
     935      !!                    noso   : number for local neighboring processors 
     936      !!                    nono   : number for local neighboring processors 
     937      !! 
     938      !!---------------------------------------------------------------------- 
     939      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
     940      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     941      !                                                         ! = T , U , V , F , W and I points 
     942      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     943      !                                                         ! =  1. , the sign is kept 
     944      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     945      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     946      !! 
     947      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     948      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     949      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     950      REAL(wp) ::   zland 
     951      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     952      !!---------------------------------------------------------------------- 
     953 
     954      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     955      ELSE                         ;   zland = 0.e0      ! zero by default 
     956      ENDIF 
     957 
     958      ! 1. standard boundary treatment 
     959      ! ------------------------------ 
     960      ! 
     961      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     962         ! 
     963         ! WARNING pt2d is defined only between nld and nle 
     964         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     965            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
     966            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
     967            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
     968         END DO 
     969         DO ji = nlci+1, jpi                 ! added column(s) (full) 
     970            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
     971            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
     972            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
     973         END DO 
     974         ! 
     975      ELSE                              ! standard close or cyclic treatment  
     976         ! 
     977         !                                   ! East-West boundaries 
     978         IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
     979            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     980            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
     981            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
     982         ELSE                                     ! closed 
     983            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     984                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     985         ENDIF 
     986         !                                   ! North-South boundaries (always closed) 
     987            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
     988                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
     989         ! 
     990      ENDIF 
     991 
     992      ! 2. East and west directions exchange 
     993      ! ------------------------------------ 
     994      ! we play with the neigbours AND the row number because of the periodicity  
     995      ! 
     996      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     997      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     998         iihom = nlci-nreci 
     999         DO jl = 1, jpreci 
     1000            t2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     1001            t2we(:,jl,1) = pt2d(iihom +jl,:) 
     1002         END DO 
     1003      END SELECT 
     1004      ! 
     1005      !                           ! Migrations 
     1006      imigr = jpreci * jpj 
     1007      ! 
     1008      SELECT CASE ( nbondi ) 
     1009      CASE ( -1 ) 
     1010         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     1011         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1012         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1013      CASE ( 0 ) 
     1014         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1015         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     1016         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1017         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1018         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1019         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1020      CASE ( 1 ) 
     1021         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1022         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1023         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1024      END SELECT 
     1025      ! 
     1026      !                           ! Write Dirichlet lateral conditions 
     1027      iihom = nlci - jpreci 
     1028      ! 
     1029      SELECT CASE ( nbondi ) 
     1030      CASE ( -1 ) 
     1031         DO jl = 1, jpreci 
     1032            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1033         END DO 
     1034      CASE ( 0 ) 
     1035         DO jl = 1, jpreci 
     1036            pt2d(jl      ,:) = t2we(:,jl,2) 
     1037            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1038         END DO 
     1039      CASE ( 1 ) 
     1040         DO jl = 1, jpreci 
     1041            pt2d(jl      ,:) = t2we(:,jl,2) 
     1042         END DO 
     1043      END SELECT 
     1044 
     1045 
     1046      ! 3. North and south directions 
     1047      ! ----------------------------- 
     1048      ! always closed : we play only with the neigbours 
     1049      ! 
     1050      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     1051         ijhom = nlcj-nrecj 
     1052         DO jl = 1, jprecj 
     1053            t2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     1054            t2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     1055         END DO 
     1056      ENDIF 
     1057      ! 
     1058      !                           ! Migrations 
     1059      imigr = jprecj * jpi 
     1060      ! 
     1061      SELECT CASE ( nbondj ) 
     1062      CASE ( -1 ) 
     1063         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     1064         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1065         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1066      CASE ( 0 ) 
     1067         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1068         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     1069         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1070         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1071         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1072         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1073      CASE ( 1 ) 
     1074         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1075         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1076         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1077      END SELECT 
     1078      ! 
     1079      !                           ! Write Dirichlet lateral conditions 
     1080      ijhom = nlcj - jprecj 
     1081      ! 
     1082      SELECT CASE ( nbondj ) 
     1083      CASE ( -1 ) 
     1084         DO jl = 1, jprecj 
     1085            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1086         END DO 
     1087      CASE ( 0 ) 
     1088         DO jl = 1, jprecj 
     1089            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1090            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1091         END DO 
     1092      CASE ( 1 )  
     1093         DO jl = 1, jprecj 
     1094            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1095         END DO 
     1096      END SELECT 
     1097 
     1098 
     1099      ! 4. north fold treatment 
     1100      ! ----------------------- 
     1101      ! 
    7361102      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    7371103         ! 
     
    17812147      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend 
    17822148      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace 
     2149      LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 
    17832150      !!---------------------------------------------------------------------- 
    17842151 
     
    18062173         CALL mppstop 
    18072174      ENDIF 
    1808        
     2175 
    18092176      ! Communication level by level 
    18102177      ! ---------------------------- 
    18112178!!gm Remark : this is very time consumming!!! 
    18122179      !                                         ! ------------------------ ! 
     2180            IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 
     2181            ! there is nothing to be migrated 
     2182               lmigr = .FALSE. 
     2183            ELSE 
     2184              lmigr = .TRUE. 
     2185            ENDIF 
     2186 
     2187      IF( lmigr ) THEN 
     2188 
    18132189      DO jk = 1, kk                             !   Loop over the levels   ! 
    18142190         !                                      ! ------------------------ ! 
     
    18322208         ! --------------------------- 
    18332209         ! 
     2210       IF( ktype == 1 ) THEN 
     2211 
    18342212         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18352213            iihom = nlci-nreci 
    1836             DO jl = 1, jpreci 
    1837                t2ew(:,jl,1) = ztab(jpreci+jl,:) 
    1838                t2we(:,jl,1) = ztab(iihom +jl,:) 
    1839             END DO 
     2214            t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 
     2215            t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 
    18402216         ENDIF 
    18412217         ! 
    18422218         !                              ! Migrations 
    1843          imigr=jpreci*jpj 
     2219         imigr = jpreci 
    18442220         ! 
    18452221         IF( nbondi == -1 ) THEN 
     
    18642240         ! 
    18652241         IF( nbondi == 0 .OR. nbondi == 1 ) THEN 
    1866             DO jl = 1, jpreci 
    1867                ztab(jl,:) = t2we(:,jl,2) 
    1868             END DO 
     2242            ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 
    18692243         ENDIF 
    18702244         IF( nbondi == -1 .OR. nbondi == 0 ) THEN 
    1871             DO jl = 1, jpreci 
    1872                ztab(iihom+jl,:) = t2ew(:,jl,2) 
    1873             END DO 
     2245            ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 
    18742246         ENDIF 
    1875  
     2247       ENDIF  ! (ktype == 1) 
    18762248 
    18772249         ! 2. North and south directions 
    18782250         ! ----------------------------- 
    18792251         ! 
     2252       IF(ktype == 2 ) THEN 
    18802253         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18812254            ijhom = nlcj-nrecj 
    1882             DO jl = 1, jprecj 
    1883                t2sn(:,jl,1) = ztab(:,ijhom +jl) 
    1884                t2ns(:,jl,1) = ztab(:,jprecj+jl) 
    1885             END DO 
     2255            t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 
     2256            t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 
    18862257         ENDIF 
    18872258         ! 
    18882259         !                              ! Migrations 
    1889          imigr = jprecj * jpi 
     2260         imigr = jprecj 
    18902261         ! 
    18912262         IF( nbondj == -1 ) THEN 
     
    19092280         ijhom = nlcj - jprecj 
    19102281         IF( nbondj == 0 .OR. nbondj == 1 ) THEN 
    1911             DO jl = 1, jprecj 
    1912                ztab(:,jl) = t2sn(:,jl,2) 
    1913             END DO 
     2282            ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 
    19142283         ENDIF 
    19152284         IF( nbondj == 0 .OR. nbondj == -1 ) THEN 
    1916             DO jl = 1, jprecj 
    1917                ztab(:,ijhom+jl) = t2ns(:,jl,2) 
    1918             END DO 
     2285            ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 
    19192286         ENDIF 
     2287         ENDIF    ! (ktype == 2) 
    19202288         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 
    19212289            DO jj = ijpt0, ijpt1            ! north/south boundaries 
    19222290               DO ji = iipt0,ilpt1 
    1923                   ptab(ji,jk) = ztab(ji,jj)   
     2291                  ptab(ji,jk) = ztab(ji,jj) 
    19242292               END DO 
    19252293            END DO 
     
    19272295            DO jj = ijpt0, ilpt1            ! east/west boundaries 
    19282296               DO ji = iipt0,iipt1 
    1929                   ptab(jj,jk) = ztab(ji,jj)  
     2297                  ptab(jj,jk) = ztab(ji,jj) 
    19302298               END DO 
    19312299            END DO 
     
    19342302      END DO 
    19352303      ! 
     2304      ENDIF ! ( lmigr ) 
    19362305      CALL wrk_dealloc( jpi,jpj, ztab ) 
    19372306      ! 
     
    25332902   END SUBROUTINE mpp_lbc_north_e 
    25342903 
     2904      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
     2905      !!---------------------------------------------------------------------- 
     2906      !!                  ***  routine mpp_lnk_bdy_3d  *** 
     2907      !! 
     2908      !! ** Purpose :   Message passing management 
     2909      !! 
     2910      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     2911      !!      between processors following neighboring subdomains. 
     2912      !!            domain parameters 
     2913      !!                    nlci   : first dimension of the local subdomain 
     2914      !!                    nlcj   : second dimension of the local subdomain 
     2915      !!                    nbondi_bdy : mark for "east-west local boundary" 
     2916      !!                    nbondj_bdy : mark for "north-south local boundary" 
     2917      !!                    noea   : number for local neighboring processors  
     2918      !!                    nowe   : number for local neighboring processors 
     2919      !!                    noso   : number for local neighboring processors 
     2920      !!                    nono   : number for local neighboring processors 
     2921      !! 
     2922      !! ** Action  :   ptab with update value at its periphery 
     2923      !! 
     2924      !!---------------------------------------------------------------------- 
     2925 
     2926      USE lbcnfd          ! north fold 
     2927 
     2928      INCLUDE 'mpif.h' 
     2929 
     2930      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     2931      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     2932      !                                                             ! = T , U , V , F , W points 
     2933      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     2934      !                                                             ! =  1. , the sign is kept 
     2935      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     2936      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     2937      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     2938      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     2939      REAL(wp) ::   zland 
     2940      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     2941      !!---------------------------------------------------------------------- 
     2942 
     2943      zland = 0.e0 
     2944 
     2945      ! 1. standard boundary treatment 
     2946      ! ------------------------------ 
     2947       
     2948      !                                   ! East-West boundaries 
     2949      !                                        !* Cyclic east-west 
     2950 
     2951      IF( nbondi == 2) THEN 
     2952        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     2953          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     2954          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     2955        ELSE 
     2956          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2957          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2958        ENDIF 
     2959      ELSEIF(nbondi == -1) THEN 
     2960        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2961      ELSEIF(nbondi == 1) THEN 
     2962        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2963      ENDIF                                     !* closed 
     2964 
     2965      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     2966        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     2967      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     2968        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     2969      ENDIF 
     2970       
     2971      ! 
     2972 
     2973      ! 2. East and west directions exchange 
     2974      ! ------------------------------------ 
     2975      ! we play with the neigbours AND the row number because of the periodicity  
     2976      ! 
     2977      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     2978      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     2979         iihom = nlci-nreci 
     2980         DO jl = 1, jpreci 
     2981            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     2982            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     2983         END DO 
     2984      END SELECT 
     2985      ! 
     2986      !                           ! Migrations 
     2987      imigr = jpreci * jpj * jpk 
     2988      ! 
     2989      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     2990      CASE ( -1 ) 
     2991         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     2992      CASE ( 0 ) 
     2993         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2994         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     2995      CASE ( 1 ) 
     2996         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2997      END SELECT 
     2998      ! 
     2999      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3000      CASE ( -1 ) 
     3001         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3002      CASE ( 0 ) 
     3003         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3004         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3005      CASE ( 1 ) 
     3006         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3007      END SELECT 
     3008      ! 
     3009      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3010      CASE ( -1 ) 
     3011         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3012      CASE ( 0 ) 
     3013         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3014         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3015      CASE ( 1 ) 
     3016         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3017      END SELECT 
     3018      ! 
     3019      !                           ! Write Dirichlet lateral conditions 
     3020      iihom = nlci-jpreci 
     3021      ! 
     3022      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3023      CASE ( -1 ) 
     3024         DO jl = 1, jpreci 
     3025            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3026         END DO 
     3027      CASE ( 0 ) 
     3028         DO jl = 1, jpreci 
     3029            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3030            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3031         END DO 
     3032      CASE ( 1 ) 
     3033         DO jl = 1, jpreci 
     3034            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3035         END DO 
     3036      END SELECT 
     3037 
     3038 
     3039      ! 3. North and south directions 
     3040      ! ----------------------------- 
     3041      ! always closed : we play only with the neigbours 
     3042      ! 
     3043      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3044         ijhom = nlcj-nrecj 
     3045         DO jl = 1, jprecj 
     3046            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     3047            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     3048         END DO 
     3049      ENDIF 
     3050      ! 
     3051      !                           ! Migrations 
     3052      imigr = jprecj * jpi * jpk 
     3053      ! 
     3054      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3055      CASE ( -1 ) 
     3056         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     3057      CASE ( 0 ) 
     3058         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3059         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     3060      CASE ( 1 ) 
     3061         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3062      END SELECT 
     3063      ! 
     3064      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3065      CASE ( -1 ) 
     3066         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3067      CASE ( 0 ) 
     3068         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3069         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3070      CASE ( 1 ) 
     3071         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3072      END SELECT 
     3073      ! 
     3074      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3075      CASE ( -1 ) 
     3076         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3077      CASE ( 0 ) 
     3078         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3079         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3080      CASE ( 1 ) 
     3081         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3082      END SELECT 
     3083      ! 
     3084      !                           ! Write Dirichlet lateral conditions 
     3085      ijhom = nlcj-jprecj 
     3086      ! 
     3087      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3088      CASE ( -1 ) 
     3089         DO jl = 1, jprecj 
     3090            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3091         END DO 
     3092      CASE ( 0 ) 
     3093         DO jl = 1, jprecj 
     3094            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     3095            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3096         END DO 
     3097      CASE ( 1 ) 
     3098         DO jl = 1, jprecj 
     3099            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     3100         END DO 
     3101      END SELECT 
     3102 
     3103 
     3104      ! 4. north fold treatment 
     3105      ! ----------------------- 
     3106      ! 
     3107      IF( npolj /= 0) THEN 
     3108         ! 
     3109         SELECT CASE ( jpni ) 
     3110         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3111         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3112         END SELECT 
     3113         ! 
     3114      ENDIF 
     3115      ! 
     3116   END SUBROUTINE mpp_lnk_bdy_3d 
     3117 
     3118      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
     3119      !!---------------------------------------------------------------------- 
     3120      !!                  ***  routine mpp_lnk_bdy_2d  *** 
     3121      !! 
     3122      !! ** Purpose :   Message passing management 
     3123      !! 
     3124      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     3125      !!      between processors following neighboring subdomains. 
     3126      !!            domain parameters 
     3127      !!                    nlci   : first dimension of the local subdomain 
     3128      !!                    nlcj   : second dimension of the local subdomain 
     3129      !!                    nbondi_bdy : mark for "east-west local boundary" 
     3130      !!                    nbondj_bdy : mark for "north-south local boundary" 
     3131      !!                    noea   : number for local neighboring processors  
     3132      !!                    nowe   : number for local neighboring processors 
     3133      !!                    noso   : number for local neighboring processors 
     3134      !!                    nono   : number for local neighboring processors 
     3135      !! 
     3136      !! ** Action  :   ptab with update value at its periphery 
     3137      !! 
     3138      !!---------------------------------------------------------------------- 
     3139 
     3140      USE lbcnfd          ! north fold 
     3141 
     3142      INCLUDE 'mpif.h' 
     3143 
     3144      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3145      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     3146      !                                                             ! = T , U , V , F , W points 
     3147      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     3148      !                                                             ! =  1. , the sign is kept 
     3149      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     3150      INTEGER  ::   ji, jj, jl             ! dummy loop indices 
     3151      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     3152      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     3153      REAL(wp) ::   zland 
     3154      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     3155      !!---------------------------------------------------------------------- 
     3156 
     3157      zland = 0.e0 
     3158 
     3159      ! 1. standard boundary treatment 
     3160      ! ------------------------------ 
     3161       
     3162      !                                   ! East-West boundaries 
     3163      !                                        !* Cyclic east-west 
     3164 
     3165      IF( nbondi == 2) THEN 
     3166        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     3167          ptab( 1 ,:) = ptab(jpim1,:) 
     3168          ptab(jpi,:) = ptab(  2  ,:) 
     3169        ELSE 
     3170          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3171          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3172        ENDIF 
     3173      ELSEIF(nbondi == -1) THEN 
     3174        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3175      ELSEIF(nbondi == 1) THEN 
     3176        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3177      ENDIF                                     !* closed 
     3178 
     3179      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     3180        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point 
     3181      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     3182        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north 
     3183      ENDIF 
     3184       
     3185      ! 
     3186 
     3187      ! 2. East and west directions exchange 
     3188      ! ------------------------------------ 
     3189      ! we play with the neigbours AND the row number because of the periodicity  
     3190      ! 
     3191      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     3192      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     3193         iihom = nlci-nreci 
     3194         DO jl = 1, jpreci 
     3195            t2ew(:,jl,1) = ptab(jpreci+jl,:) 
     3196            t2we(:,jl,1) = ptab(iihom +jl,:) 
     3197         END DO 
     3198      END SELECT 
     3199      ! 
     3200      !                           ! Migrations 
     3201      imigr = jpreci * jpj 
     3202      ! 
     3203      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3204      CASE ( -1 ) 
     3205         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     3206      CASE ( 0 ) 
     3207         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3208         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     3209      CASE ( 1 ) 
     3210         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3211      END SELECT 
     3212      ! 
     3213      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3214      CASE ( -1 ) 
     3215         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3216      CASE ( 0 ) 
     3217         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3218         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3219      CASE ( 1 ) 
     3220         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3221      END SELECT 
     3222      ! 
     3223      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3224      CASE ( -1 ) 
     3225         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3226      CASE ( 0 ) 
     3227         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3228         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3229      CASE ( 1 ) 
     3230         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3231      END SELECT 
     3232      ! 
     3233      !                           ! Write Dirichlet lateral conditions 
     3234      iihom = nlci-jpreci 
     3235      ! 
     3236      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3237      CASE ( -1 ) 
     3238         DO jl = 1, jpreci 
     3239            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3240         END DO 
     3241      CASE ( 0 ) 
     3242         DO jl = 1, jpreci 
     3243            ptab(jl      ,:) = t2we(:,jl,2) 
     3244            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3245         END DO 
     3246      CASE ( 1 ) 
     3247         DO jl = 1, jpreci 
     3248            ptab(jl      ,:) = t2we(:,jl,2) 
     3249         END DO 
     3250      END SELECT 
     3251 
     3252 
     3253      ! 3. North and south directions 
     3254      ! ----------------------------- 
     3255      ! always closed : we play only with the neigbours 
     3256      ! 
     3257      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3258         ijhom = nlcj-nrecj 
     3259         DO jl = 1, jprecj 
     3260            t2sn(:,jl,1) = ptab(:,ijhom +jl) 
     3261            t2ns(:,jl,1) = ptab(:,jprecj+jl) 
     3262         END DO 
     3263      ENDIF 
     3264      ! 
     3265      !                           ! Migrations 
     3266      imigr = jprecj * jpi 
     3267      ! 
     3268      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3269      CASE ( -1 ) 
     3270         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     3271      CASE ( 0 ) 
     3272         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3273         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     3274      CASE ( 1 ) 
     3275         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3276      END SELECT 
     3277      ! 
     3278      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3279      CASE ( -1 ) 
     3280         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3281      CASE ( 0 ) 
     3282         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3283         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3284      CASE ( 1 ) 
     3285         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3286      END SELECT 
     3287      ! 
     3288      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3289      CASE ( -1 ) 
     3290         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3291      CASE ( 0 ) 
     3292         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3293         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3294      CASE ( 1 ) 
     3295         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3296      END SELECT 
     3297      ! 
     3298      !                           ! Write Dirichlet lateral conditions 
     3299      ijhom = nlcj-jprecj 
     3300      ! 
     3301      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3302      CASE ( -1 ) 
     3303         DO jl = 1, jprecj 
     3304            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3305         END DO 
     3306      CASE ( 0 ) 
     3307         DO jl = 1, jprecj 
     3308            ptab(:,jl      ) = t2sn(:,jl,2) 
     3309            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3310         END DO 
     3311      CASE ( 1 ) 
     3312         DO jl = 1, jprecj 
     3313            ptab(:,jl) = t2sn(:,jl,2) 
     3314         END DO 
     3315      END SELECT 
     3316 
     3317 
     3318      ! 4. north fold treatment 
     3319      ! ----------------------- 
     3320      ! 
     3321      IF( npolj /= 0) THEN 
     3322         ! 
     3323         SELECT CASE ( jpni ) 
     3324         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3325         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3326         END SELECT 
     3327         ! 
     3328      ENDIF 
     3329      ! 
     3330   END SUBROUTINE mpp_lnk_bdy_2d 
    25353331 
    25363332   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 
Note: See TracChangeset for help on using the changeset viewer.