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 1926 – NEMO

Changeset 1926


Ignore:
Timestamp:
2010-06-10T13:06:13+02:00 (14 years ago)
Author:
acc
Message:

First implementation of mpp scalability modifications (branch:DEV_1879_mpp_sca

Location:
branches/DEV_1879_mpp_sca/NEMO/OPA_SRC
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/lib_mpp.F90

    r1874 r1926  
    159159   REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   tr2ns, tr2sn  ! 2d for north-south & south-north + extra outer halo 
    160160   REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   tr2ew, tr2we  ! 2d for east-west   & west-east   + extra outer halo 
     161 
     162   ! North fold arrays used to minimise the use of allgather operations. Set in opa_northcomms so need to be public 
     163   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                                 ! Assumed maximum number of active neighbours 
     164   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,4)        ::   isendto 
     165   INTEGER, PUBLIC,  DIMENSION (4)                 ::   nsndto 
     166   LOGICAL, PUBLIC                                 ::   lnorth_nogather = .FALSE. 
     167   INTEGER, PUBLIC                                 ::   ityp 
    161168   !!---------------------------------------------------------------------- 
    162169   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)  
     
    354361      CASE ( -1 ) 
    355362         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
    356          CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 
     363         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
    357364         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    358365      CASE ( 0 ) 
    359366         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    360367         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
    361          CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 
    362          CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 
     368         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     369         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    363370         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    364371         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    365372      CASE ( 1 ) 
    366373         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    367          CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 
     374         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    368375         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    369376      END SELECT 
     
    407414      CASE ( -1 ) 
    408415         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    409          CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 
     416         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
    410417         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    411418      CASE ( 0 ) 
    412419         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    413420         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    414          CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 
    415          CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 
     421         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     422         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    416423         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    417424         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    418425      CASE ( 1 )  
    419426         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    420          CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 
     427         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    421428         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    422429      END SELECT 
     
    548555      CASE ( -1 ) 
    549556         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    550          CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     557         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    551558         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    552559      CASE ( 0 ) 
    553560         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    554561         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
    555          CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
    556          CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     562         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     563         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    557564         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    558565         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    559566      CASE ( 1 ) 
    560567         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    561          CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     568         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    562569         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    563570      END SELECT 
     
    601608      CASE ( -1 ) 
    602609         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    603          CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     610         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    604611         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    605612      CASE ( 0 ) 
    606613         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    607614         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
    608          CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    609          CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     615         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     616         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    610617         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    611618         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    612619      CASE ( 1 ) 
    613620         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    614          CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     621         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    615622         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    616623      END SELECT 
     
    729736      CASE ( -1 ) 
    730737         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    731          CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 
     738         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
    732739         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    733740      CASE ( 0 ) 
    734741         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    735742         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    736          CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 
    737          CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 
     743         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
     744         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    738745         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    739746         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    740747      CASE ( 1 ) 
    741748         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    742          CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 
     749         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    743750         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    744751      END SELECT 
     
    788795      CASE ( -1 ) 
    789796         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    790          CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 
     797         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
    791798         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    792799      CASE ( 0 ) 
    793800         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    794801         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    795          CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 
    796          CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 
     802         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
     803         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    797804         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    798805         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    799806      CASE ( 1 )  
    800807         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    801          CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 
     808         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    802809         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    803810      END SELECT 
     
    932939      CASE ( -1 ) 
    933940         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 
    934          CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 
     941         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
    935942         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    936943      CASE ( 0 ) 
    937944         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    938945         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 
    939          CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 
    940          CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 
     946         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
     947         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    941948         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    942949         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    943950      CASE ( 1 ) 
    944951         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    945          CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 
     952         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    946953         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    947954      END SELECT 
     
    985992      CASE ( -1 ) 
    986993         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 
    987          CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 
     994         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
    988995         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    989996      CASE ( 0 ) 
    990997         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    991998         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 
    992          CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 
    993          CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 
     999         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
     1000         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    9941001         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    9951002         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    9961003      CASE ( 1 ) 
    9971004         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    998          CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 
     1005         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    9991006         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10001007      END SELECT 
     
    10511058 
    10521059 
    1053    SUBROUTINE mpprecv( ktyp, pmess, kbytes ) 
     1060   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 
    10541061      !!---------------------------------------------------------------------- 
    10551062      !!                  ***  routine mpprecv  *** 
     
    10611068      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
    10621069      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     1070      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number  
    10631071      !! 
    10641072      INTEGER :: istatus(mpi_status_size) 
    10651073      INTEGER :: iflag 
    1066       !!---------------------------------------------------------------------- 
    1067       ! 
    1068       CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag ) 
     1074      INTEGER :: use_source 
     1075      !!---------------------------------------------------------------------- 
     1076      ! 
     1077 
     1078      ! If a specific process number has been passed to the receive call,  
     1079      ! use that one. Default is to use mpi_any_source 
     1080      use_source=mpi_any_source 
     1081      if(present(ksource)) then 
     1082         use_source=ksource 
     1083      end if 
     1084 
     1085      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 
    10691086      ! 
    10701087   END SUBROUTINE mpprecv 
     
    16811698         IF( nbondi == -1 ) THEN 
    16821699            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    1683             CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     1700            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    16841701            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    16851702         ELSEIF( nbondi == 0 ) THEN 
    16861703            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    16871704            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
    1688             CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
    1689             CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     1705            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1706            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    16901707            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    16911708            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    16921709         ELSEIF( nbondi == 1 ) THEN 
    16931710            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1694             CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     1711            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    16951712            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    16961713         ENDIF 
     
    17271744         IF( nbondj == -1 ) THEN 
    17281745            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    1729             CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     1746            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    17301747            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    17311748         ELSEIF( nbondj == 0 ) THEN 
    17321749            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    17331750            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
    1734             CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    1735             CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     1751            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1752            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    17361753            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    17371754            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    17381755         ELSEIF( nbondj == 1 ) THEN 
    17391756            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    1740             CALL mpprecv( 4, t2sn(1,1,2), imigr) 
     1757            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso) 
    17411758            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    17421759         ENDIF 
     
    20452062      REAL(wp), DIMENSION(jpi   ,4,jpk)      ::   znorthloc 
    20462063      REAL(wp), DIMENSION(jpi   ,4,jpk,jpni) ::   znorthgloio 
     2064      REAL(wp), DIMENSION(jpi,   4,jpk)      ::   zfoldwrk           ! Workspace for message transfers avoiding mpi_allgather 
     2065      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req5            ! for mpi_isend when avoiding mpi_allgather 
     2066      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2067      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    20472068      !!---------------------------------------------------------------------- 
    20482069      !    
    20492070      ijpj   = 4 
     2071      ityp = -1 
    20502072      ijpjm1 = 3 
    20512073      ztab(:,:,:) = 0.e0 
     
    20582080      !                                     ! Build in procs of ncomm_north the znorthgloio 
    20592081      itaille = jpi * jpk * ijpj 
    2060       CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2061          &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2082      IF ( lnorth_nogather ) THEN 
     2083! 
     2084! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms) 
     2085! as being  involved in this process' northern boundary exchange 
     2086! 
     2087! First put local values into the global arraay 
     2088         DO jj = nlcj-ijpj+1, nlcj 
     2089           ij = jj - nlcj + ijpj 
     2090           DO ji = 1, nlci 
     2091             ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 
     2092           END DO 
     2093         END DO 
     2094 
     2095! 
     2096! Set the exchange type in order to access the correct list of active neighbours 
     2097! 
     2098         SELECT CASE ( cd_type ) 
     2099            CASE ( 'T' , 'W' ) 
     2100             ityp = 1 
     2101            CASE ( 'U' ) 
     2102             ityp = 2 
     2103            CASE ( 'V' ) 
     2104             ityp = 3 
     2105            CASE ( 'F' ) 
     2106             ityp = 4 
     2107            CASE DEFAULT 
     2108! 
     2109! Set a default value for unsupported types which will cause a fallback to 
     2110! the mpi_allgather method 
     2111! 
     2112             ityp = -1 
     2113          END SELECT 
     2114          IF ( ityp .gt. 0 ) THEN 
     2115 
     2116           DO jr = 1,nsndto(ityp) 
     2117            CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) ) 
     2118           END DO 
     2119           DO jr = 1,nsndto(ityp) 
     2120            CALL mpprecv(5, zfoldwrk, itaille, isendto(jr,ityp)) 
     2121            iproc = isendto(jr,ityp) + 1 
     2122            ildi=nldit (iproc) 
     2123            ilei=nleit (iproc) 
     2124            iilb=nimppt(iproc) 
     2125            DO jj = 1, 4 
     2126               DO ji = ildi, ilei 
     2127                  ztab(ji+iilb-1,jj,:) = zfoldwrk(ji,jj,:) 
     2128               END DO 
     2129            END DO 
     2130           END DO 
     2131           IF(l_isend) THEN 
     2132              DO jr = 1,nsndto(ityp) 
     2133                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 
     2134              END DO 
     2135           ENDIF 
     2136 
     2137          ENDIF 
     2138 
     2139      ENDIF 
     2140 
     2141      IF ( ityp .lt. 0 ) THEN 
     2142         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
     2143            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    20622144      ! 
    20632145      !                                     ! recover the global north array 
    2064       DO jr = 1, ndim_rank_north 
    2065          iproc = nrank_north(jr) + 1 
    2066          ildi  = nldit (iproc) 
    2067          ilei  = nleit (iproc) 
    2068          iilb  = nimppt(iproc) 
    2069          DO jj = 1, 4 
    2070             DO ji = ildi, ilei 
    2071                ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2146         DO jr = 1, ndim_rank_north 
     2147            iproc = nrank_north(jr) + 1 
     2148            ildi  = nldit (iproc) 
     2149            ilei  = nleit (iproc) 
     2150            iilb  = nimppt(iproc) 
     2151            DO jj = 1, 4 
     2152               DO ji = ildi, ilei 
     2153                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2154               END DO 
    20722155            END DO 
    20732156         END DO 
    2074       END DO 
     2157      ENDIF 
     2158      ! 
     2159! The ztab array has been either: 
     2160!  a. Fully populated by the mpi_allgather operation or 
     2161!  b. Had the active points for this domain and northern neighbours populated by peer to peer exchanges 
     2162! Either way the array may be folded by lbc_nfd and the result for the span of this domain will be identical. 
    20752163      ! 
    20762164      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
     
    21112199      REAL(wp), DIMENSION(jpi   ,4)      ::   znorthloc 
    21122200      REAL(wp), DIMENSION(jpi   ,4,jpni) ::   znorthgloio 
     2201      REAL(wp), DIMENSION(jpi,   4)      ::   zfoldwrk           ! Workspace for message transfers avoiding mpi_allgather 
     2202      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req5            ! for mpi_isend when avoiding mpi_allgather 
     2203      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2204      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    21132205      !!---------------------------------------------------------------------- 
    21142206      ! 
    21152207      ijpj   = 4 
     2208      ityp = -1 
    21162209      ijpjm1 = 3 
    21172210      ztab(:,:) = 0.e0 
     
    21242217      !                                     ! Build in procs of ncomm_north the znorthgloio 
    21252218      itaille = jpi * ijpj 
    2126       CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
    2127          &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2128       ! 
    2129       DO jr = 1, ndim_rank_north            ! recover the global north array 
    2130          iproc = nrank_north(jr) + 1 
    2131          ildi=nldit (iproc) 
    2132          ilei=nleit (iproc) 
    2133          iilb=nimppt(iproc) 
    2134          DO jj = 1, 4 
    2135             DO ji = ildi, ilei 
    2136                ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
     2219      IF ( lnorth_nogather ) THEN 
     2220! 
     2221! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms)  
     2222! as being  involved in this process' northern boundary exchange 
     2223! 
     2224! First put local values into the global array 
     2225! 
     2226         DO jj = nlcj-ijpj+1, nlcj 
     2227           ij = jj - nlcj + ijpj 
     2228           DO ji = 1, nlci 
     2229             ztab(ji+nimpp-1,ij) = pt2d(ji,jj) 
     2230           END DO 
     2231         END DO 
     2232 
     2233! 
     2234! Set the exchange type in order to access the correct list of active neighbours 
     2235! 
     2236         SELECT CASE ( cd_type ) 
     2237            CASE ( 'T' , 'W' ) 
     2238             ityp = 1 
     2239            CASE ( 'U' ) 
     2240             ityp = 2 
     2241            CASE ( 'V' ) 
     2242             ityp = 3 
     2243            CASE ( 'F' ) 
     2244             ityp = 4 
     2245            CASE DEFAULT 
     2246! 
     2247! Set a default value for unsupported types which will cause a fallback to 
     2248! the mpi_allgather method 
     2249! 
     2250             ityp = -1 
     2251          END SELECT 
     2252 
     2253          IF ( ityp .gt. 0 ) THEN 
     2254 
     2255           DO jr = 1,nsndto(ityp) 
     2256            CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) ) 
     2257           END DO 
     2258           DO jr = 1,nsndto(ityp) 
     2259            CALL mpprecv(5, zfoldwrk, itaille, isendto(jr,ityp)) 
     2260            iproc = isendto(jr,ityp) + 1 
     2261            ildi=nldit (iproc) 
     2262            ilei=nleit (iproc) 
     2263            iilb=nimppt(iproc) 
     2264            DO jj = 1, 4 
     2265               DO ji = ildi, ilei 
     2266                  ztab(ji+iilb-1,jj) = zfoldwrk(ji,jj) 
     2267               END DO 
    21372268            END DO 
    2138          END DO 
    2139       END DO 
    2140       ! 
    2141       CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2142       ! 
    2143       ! 
    2144       DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2145          ij = jj - nlcj + ijpj 
    2146          DO ji = 1, nlci 
    2147             pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
    2148          END DO 
    2149       END DO 
     2269           END DO 
     2270           IF(l_isend) THEN 
     2271              DO jr = 1,nsndto(ityp) 
     2272                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 
     2273              END DO 
     2274           ENDIF 
     2275 
     2276          ENDIF 
     2277 
     2278      ENDIF 
     2279 
     2280      IF ( ityp .lt. 0 ) THEN 
     2281       CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
     2282          &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2283      ! 
     2284       DO jr = 1, ndim_rank_north            ! recover the global north array 
     2285          iproc = nrank_north(jr) + 1 
     2286          ildi=nldit (iproc) 
     2287          ilei=nleit (iproc) 
     2288          iilb=nimppt(iproc) 
     2289          DO jj = 1, 4 
     2290             DO ji = ildi, ilei 
     2291                ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
     2292             END DO 
     2293          END DO 
     2294       END DO 
     2295      ENDIF 
     2296      ! 
     2297! The ztab array has been either: 
     2298!  a. Fully populated by the mpi_allgather operation or 
     2299!  b. Had the active points for this domain and northern neighbours populated by peer to peer exchanges 
     2300! Either way the array may be folded by lbc_nfd and the result for the span of this domain will be identical. 
     2301      ! 
     2302       CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
     2303      ! 
     2304      ! 
     2305       DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2306          ij = jj - nlcj + ijpj 
     2307          DO ji = 1, nlci 
     2308             pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
     2309          END DO 
     2310       END DO 
    21502311      ! 
    21512312   END SUBROUTINE mpp_lbc_north_2d 
  • branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/opa.F90

    r1793 r1926  
    257257      ENDIF 
    258258!!gm c1d end 
     259 
     260      CALL opa_northcomms                   ! Initialise the northfold neighbour lists (must be done after the masks are defined) 
    259261 
    260262      IF( ln_ctl )   CALL prt_ctl_init      ! Print control 
     
    407409   END SUBROUTINE opa_closefile 
    408410 
     411   SUBROUTINE opa_northcomms 
     412      !!====================================================================== 
     413      !!                     ***  ROUTINE  opa_northcomms  *** 
     414      !! opa_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging 
     415      !!===================================================================== 
     416      !!---------------------------------------------------------------------- 
     417      !!  
     418      !! ** Purpose :   Initialization of the northern neighbours lists. 
     419      !!---------------------------------------------------------------------- 
     420 
     421      INTEGER ::   ji, jj, jk, ij    ! dummy loop indices 
     422      INTEGER ::   ijpj              ! ??? 
     423      INTEGER,  DIMENSION (jpi,4,4) ::   ifoldnbrs 
     424      REAL(wp), DIMENSION (jpi,jpj) ::   znnbrs     ! workspace 
     425      LOGICAL,  DIMENSION (jpnij)   ::   lrankset   ! workspace 
     426 
     427      IF(lwp) WRITE(numout,*) 
     428      IF(lwp) WRITE(numout,*) 'opa_northcomms : Initialization of the northern neighbours lists' 
     429      IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     430 
     431      !!---------------------------------------------------------------------- 
     432      nsndto = 0 
     433      isendto = -1 
     434      ijpj   = 4 
     435      ! 
     436! Exchange and store ranks on northern rows 
     437 
     438      lrankset = .FALSE. 
     439      znnbrs = narea * tmask(:,:,1) 
     440      CALL lbc_lnk( znnbrs, 'T', 1. ) 
     441 
     442      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 
     443        do jj = nlcj-ijpj+1, nlcj 
     444         ij = jj - nlcj + ijpj 
     445         ifoldnbrs(:,ij,1) = int(znnbrs(:,jj)) 
     446         do ji = 1,jpi 
     447          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 
     448         &       lrankset(int(znnbrs(ji,jj))) = .true. 
     449         end do 
     450        end do 
     451 
     452        do jj = 1,jpnij 
     453         IF (lrankset(jj)) THEN 
     454          nsndto(1) = nsndto(1) + 1 
     455          IF(nsndto(1) .gt. jpmaxngh ) THEN 
     456           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', & 
     457           &              ' jpmaxngh will need to be increased ') 
     458          ENDIF 
     459          isendto(nsndto(1),1) = jj-1   ! narea converted to MPI rank 
     460         ENDIF 
     461        end do 
     462      ENDIF 
     463       
     464      lrankset = .FALSE. 
     465      znnbrs = narea * umask(:,:,1) 
     466      CALL lbc_lnk( znnbrs, 'U', 1. ) 
     467 
     468      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 
     469        do jj = nlcj-ijpj+1, nlcj 
     470         ij = jj - nlcj + ijpj 
     471         ifoldnbrs(:,ij,2) = int(znnbrs(:,jj)) 
     472         do ji = 1,jpi 
     473          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 
     474         &       lrankset(int(znnbrs(ji,jj))) = .true. 
     475         end do 
     476        end do 
     477 
     478        do jj = 1,jpnij 
     479         IF (lrankset(jj)) THEN 
     480          nsndto(2) = nsndto(2) + 1 
     481          IF(nsndto(2) .gt. jpmaxngh ) THEN 
     482           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', & 
     483           &              ' jpmaxngh will need to be increased ') 
     484          ENDIF 
     485          isendto(nsndto(2),2) = jj-1   ! narea converted to MPI rank 
     486         ENDIF 
     487        end do 
     488      ENDIF 
     489 
     490      lrankset = .FALSE. 
     491      znnbrs = narea * vmask(:,:,1) 
     492      CALL lbc_lnk( znnbrs, 'V', 1. ) 
     493 
     494      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 
     495        do jj = nlcj-ijpj+1, nlcj 
     496         ij = jj - nlcj + ijpj 
     497         ifoldnbrs(:,ij,3) = int(znnbrs(:,jj)) 
     498         do ji = 1,jpi 
     499          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 
     500         &       lrankset(int(znnbrs(ji,jj))) = .true. 
     501         end do 
     502        end do 
     503 
     504        do jj = 1,jpnij 
     505         IF (lrankset(jj)) THEN 
     506          nsndto(3) = nsndto(3) + 1 
     507          IF(nsndto(3) .gt. jpmaxngh ) THEN 
     508           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', & 
     509           &              ' jpmaxngh will need to be increased ') 
     510          ENDIF 
     511          isendto(nsndto(3),3) = jj-1   ! narea converted to MPI rank 
     512         ENDIF 
     513        end do 
     514      ENDIF 
     515 
     516      lrankset = .FALSE. 
     517      znnbrs = narea * fmask(:,:,1) 
     518! 
     519! filter top rows to counter any strong slip conditions 
     520! 
     521      do jj = nlcj-ijpj+1, nlcj 
     522      do ji = 1,jpi 
     523       znnbrs(ji,jj) = narea * MIN(1.0,fmask(ji,jj,1)) 
     524      end do 
     525      enddo 
     526      CALL lbc_lnk( znnbrs, 'F', 1. ) 
     527 
     528      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 
     529        do jj = nlcj-ijpj+1, nlcj 
     530         ij = jj - nlcj + ijpj 
     531         ifoldnbrs(:,ij,4) = int(znnbrs(:,jj)) 
     532         do ji = 1,jpi 
     533          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 
     534         &       lrankset(int(znnbrs(ji,jj))) = .true. 
     535         end do 
     536        end do 
     537 
     538        do jj = 1,jpnij 
     539         IF (lrankset(jj)) THEN 
     540          nsndto(4) = nsndto(4) + 1 
     541          IF(nsndto(4) .gt. jpmaxngh ) THEN 
     542           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', & 
     543           &              ' jpmaxngh will need to be increased ') 
     544          ENDIF 
     545          isendto(nsndto(4),4) = jj-1   ! narea converted to MPI rank 
     546         ENDIF 
     547        end do 
     548 
     549        lnorth_nogather = .TRUE. 
     550      ENDIF 
     551 
     552   END SUBROUTINE opa_northcomms 
    409553   !!====================================================================== 
    410554END MODULE opa 
Note: See TracChangeset for help on using the changeset viewer.