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 3294 for trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2012-01-28T17:44:18+01:00 (12 years ago)
Author:
rblod
Message:

Merge of 3.4beta into the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r2731 r3294  
    6464   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    6565   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
     66   PUBLIC   mppscatter, mppgather 
    6667   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl 
    6768   PUBLIC   mppsize 
    … …  
    164165   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztab, znorthloc 
    165166   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE   ::   znorthgloio 
     167   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   zfoldwk      ! Workspace for message transfers avoiding mpi_allgather 
    166168 
    167169   ! Arrays used in mpp_lbc_north_2d() 
    168170   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_2d, znorthloc_2d 
    169171   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_2d 
     172   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   zfoldwk_2d    ! Workspace for message transfers avoiding mpi_allgather 
    170173 
    171174   ! Arrays used in mpp_lbc_north_e() 
    … …  
    173176   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_e 
    174177 
     178   ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 
     179   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours 
     180   INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges  
     181   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto 
     182   INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto 
     183   LOGICAL, PUBLIC                                  ::   ln_nnogather     = .FALSE.  ! namelist control of northfold comms 
     184   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms 
     185   INTEGER, PUBLIC                                  ::   ityp 
    175186   !!---------------------------------------------------------------------- 
    176187   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    203214         ! 
    204215         &      ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) ,                        & 
     216         &      zfoldwk(jpi,4,jpk) ,                                                                             & 
    205217         ! 
    206218         &      ztab_2d(jpiglo,4)  , znorthloc_2d(jpi,4)  , znorthgloio_2d(jpi,4,jpni)  ,                        & 
     219         &      zfoldwk_2d(jpi,4)  ,                                                                             & 
    207220         ! 
    208221         &      ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) ,   & 
    … …  
    232245      LOGICAL ::   mpi_was_called 
    233246      ! 
    234       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij 
     247      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather 
    235248      !!---------------------------------------------------------------------- 
    236249      ! 
    … …  
    269282         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij; ii = ii +1 
    270283      END IF 
     284 
     285      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    271286 
    272287      CALL mpi_initialized ( mpi_was_called, code ) 
    … …  
    441456      CASE ( -1 ) 
    442457         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
    443          CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 
     458         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
    444459         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    445460      CASE ( 0 ) 
    446461         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    447462         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
    448          CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 
    449          CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 
     463         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     464         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    450465         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    451466         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    452467      CASE ( 1 ) 
    453468         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    454          CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 
     469         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    455470         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    456471      END SELECT 
    … …  
    494509      CASE ( -1 ) 
    495510         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    496          CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 
     511         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
    497512         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    498513      CASE ( 0 ) 
    499514         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    500515         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    501          CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 
    502          CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 
     516         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     517         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    503518         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    504519         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    505520      CASE ( 1 )  
    506521         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    507          CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 
     522         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    508523         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    509524      END SELECT 
    … …  
    635650      CASE ( -1 ) 
    636651         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    637          CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     652         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    638653         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    639654      CASE ( 0 ) 
    640655         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    641656         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
    642          CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
    643          CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     657         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     658         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    644659         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    645660         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    646661      CASE ( 1 ) 
    647662         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    648          CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     663         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    649664         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    650665      END SELECT 
    … …  
    688703      CASE ( -1 ) 
    689704         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    690          CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     705         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    691706         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    692707      CASE ( 0 ) 
    693708         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    694709         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
    695          CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    696          CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     710         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     711         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    697712         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    698713         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    699714      CASE ( 1 ) 
    700715         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    701          CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     716         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    702717         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    703718      END SELECT 
    … …  
    816831      CASE ( -1 ) 
    817832         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    818          CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 
     833         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
    819834         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    820835      CASE ( 0 ) 
    821836         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    822837         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    823          CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 
    824          CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 
     838         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
     839         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    825840         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    826841         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    827842      CASE ( 1 ) 
    828843         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    829          CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 
     844         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    830845         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    831846      END SELECT 
    … …  
    875890      CASE ( -1 ) 
    876891         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    877          CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 
     892         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
    878893         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    879894      CASE ( 0 ) 
    880895         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    881896         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    882          CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 
    883          CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 
     897         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
     898         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    884899         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    885900         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    886901      CASE ( 1 )  
    887902         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    888          CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 
     903         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    889904         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    890905      END SELECT 
    … …  
    10191034      CASE ( -1 ) 
    10201035         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 
    1021          CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 
     1036         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
    10221037         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10231038      CASE ( 0 ) 
    10241039         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    10251040         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 
    1026          CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 
    1027          CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 
     1041         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
     1042         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10281043         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10291044         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10301045      CASE ( 1 ) 
    10311046         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    1032          CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 
     1047         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10331048         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10341049      END SELECT 
    … …  
    10721087      CASE ( -1 ) 
    10731088         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 
    1074          CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 
     1089         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
    10751090         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10761091      CASE ( 0 ) 
    10771092         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    10781093         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 
    1079          CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 
    1080          CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 
     1094         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
     1095         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10811096         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10821097         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10831098      CASE ( 1 ) 
    10841099         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    1085          CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 
     1100         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10861101         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10871102      END SELECT 
    … …  
    11381153 
    11391154 
    1140    SUBROUTINE mpprecv( ktyp, pmess, kbytes ) 
     1155   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 
    11411156      !!---------------------------------------------------------------------- 
    11421157      !!                  ***  routine mpprecv  *** 
    … …  
    11481163      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
    11491164      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     1165      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number  
    11501166      !! 
    11511167      INTEGER :: istatus(mpi_status_size) 
    11521168      INTEGER :: iflag 
    1153       !!---------------------------------------------------------------------- 
    1154       ! 
    1155       CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag ) 
     1169      INTEGER :: use_source 
     1170      !!---------------------------------------------------------------------- 
     1171      ! 
     1172 
     1173      ! If a specific process number has been passed to the receive call,  
     1174      ! use that one. Default is to use mpi_any_source 
     1175      use_source=mpi_any_source 
     1176      if(present(ksource)) then 
     1177         use_source=ksource 
     1178      end if 
     1179 
     1180      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 
    11561181      ! 
    11571182   END SUBROUTINE mpprecv 
    … …  
    17151740      !!                  ***  routine mppstop  *** 
    17161741      !!                    
    1717       !! ** purpose :   Stop massilively parallel processors method 
     1742      !! ** purpose :   Stop massively parallel processors method 
    17181743      !! 
    17191744      !!---------------------------------------------------------------------- 
    … …  
    17471772      !! 
    17481773      !!---------------------------------------------------------------------- 
    1749       USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    1750       USE wrk_nemo, ONLY:   ztab => wrk_2d_1 
     1774      USE wrk_nemo        ! Memory allocation 
    17511775      ! 
    17521776      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices 
    … …  
    17651789      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend 
    17661790      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend 
    1767       !!---------------------------------------------------------------------- 
    1768  
    1769       IF( wrk_in_use(2, 1) ) THEN 
    1770          WRITE(kumout, cform_err) 
    1771          WRITE(kumout,*) 'mppobc : requested workspace array unavailable' 
    1772          CALL mppstop 
    1773       ENDIF 
     1791      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace 
     1792      !!---------------------------------------------------------------------- 
     1793 
     1794      CALL wrk_alloc( jpi,jpj, ztab ) 
    17741795 
    17751796      ! boundary condition initialization 
    … …  
    18331854         IF( nbondi == -1 ) THEN 
    18341855            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    1835             CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     1856            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    18361857            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18371858         ELSEIF( nbondi == 0 ) THEN 
    18381859            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    18391860            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
    1840             CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
    1841             CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     1861            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1862            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18421863            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18431864            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18441865         ELSEIF( nbondi == 1 ) THEN 
    18451866            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1846             CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     1867            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18471868            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18481869         ENDIF 
    … …  
    18791900         IF( nbondj == -1 ) THEN 
    18801901            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    1881             CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     1902            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    18821903            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18831904         ELSEIF( nbondj == 0 ) THEN 
    18841905            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    18851906            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
    1886             CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    1887             CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     1907            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1908            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    18881909            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18891910            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18901911         ELSEIF( nbondj == 1 ) THEN 
    18911912            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    1892             CALL mpprecv( 4, t2sn(1,1,2), imigr) 
     1913            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso) 
    18931914            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18941915         ENDIF 
    … …  
    19221943      END DO 
    19231944      ! 
    1924       IF( wrk_not_released(2, 1) ) THEN 
    1925          WRITE(kumout, cform_err) 
    1926          WRITE(kumout,*) 'mppobc : failed to release workspace array' 
    1927          CALL mppstop 
    1928       ENDIF 
     1945      CALL wrk_dealloc( jpi,jpj, ztab ) 
    19291946      ! 
    19301947   END SUBROUTINE mppobc 
    … …  
    22092226      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    22102227      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2228      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2229      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2230      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22112231      !!---------------------------------------------------------------------- 
    22122232      !    
    22132233      ijpj   = 4 
     2234      ityp = -1 
    22142235      ijpjm1 = 3 
    22152236      ztab(:,:,:) = 0.e0 
    … …  
    22222243      !                                     ! Build in procs of ncomm_north the znorthgloio 
    22232244      itaille = jpi * jpk * ijpj 
    2224       CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2225          &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2226       ! 
    2227       !                                     ! recover the global north array 
    2228       DO jr = 1, ndim_rank_north 
    2229          iproc = nrank_north(jr) + 1 
    2230          ildi  = nldit (iproc) 
    2231          ilei  = nleit (iproc) 
    2232          iilb  = nimppt(iproc) 
    2233          DO jj = 1, 4 
    2234             DO ji = ildi, ilei 
    2235                ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2245      IF ( l_north_nogather ) THEN 
     2246         ! 
     2247         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2248         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2249         ! 
     2250         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2251            ij = jj - nlcj + ijpj 
     2252            DO ji = 1, nlci 
     2253               ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 
    22362254            END DO 
    22372255         END DO 
    2238       END DO 
     2256 
     2257         ! 
     2258         ! Set the exchange type in order to access the correct list of active neighbours 
     2259         ! 
     2260         SELECT CASE ( cd_type ) 
     2261            CASE ( 'T' , 'W' ) 
     2262               ityp = 1 
     2263            CASE ( 'U' ) 
     2264               ityp = 2 
     2265            CASE ( 'V' ) 
     2266               ityp = 3 
     2267            CASE ( 'F' ) 
     2268               ityp = 4 
     2269            CASE ( 'I' ) 
     2270               ityp = 5 
     2271            CASE DEFAULT 
     2272               ityp = -1                    ! Set a default value for unsupported types which  
     2273                                            ! will cause a fallback to the mpi_allgather method 
     2274         END SELECT 
     2275         IF ( ityp .gt. 0 ) THEN 
     2276 
     2277            DO jr = 1,nsndto(ityp) 
     2278               CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
     2279            END DO 
     2280            DO jr = 1,nsndto(ityp) 
     2281               CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 
     2282               iproc = isendto(jr,ityp) + 1 
     2283               ildi = nldit (iproc) 
     2284               ilei = nleit (iproc) 
     2285               iilb = nimppt(iproc) 
     2286               DO jj = 1, ijpj 
     2287                  DO ji = ildi, ilei 
     2288                     ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 
     2289                  END DO 
     2290               END DO 
     2291            END DO 
     2292            IF (l_isend) THEN 
     2293               DO jr = 1,nsndto(ityp) 
     2294                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2295               END DO 
     2296            ENDIF 
     2297 
     2298         ENDIF 
     2299 
     2300      ENDIF 
     2301 
     2302      IF ( ityp .lt. 0 ) THEN 
     2303         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
     2304            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2305         ! 
     2306         DO jr = 1, ndim_rank_north         ! recover the global north array 
     2307            iproc = nrank_north(jr) + 1 
     2308            ildi  = nldit (iproc) 
     2309            ilei  = nleit (iproc) 
     2310            iilb  = nimppt(iproc) 
     2311            DO jj = 1, ijpj 
     2312               DO ji = ildi, ilei 
     2313                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2314               END DO 
     2315            END DO 
     2316         END DO 
     2317      ENDIF 
     2318      ! 
     2319      ! The ztab array has been either: 
     2320      !  a. Fully populated by the mpi_allgather operation or 
     2321      !  b. Had the active points for this domain and northern neighbours populated  
     2322      !     by peer to peer exchanges 
     2323      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2324      ! this domain will be identical. 
    22392325      ! 
    22402326      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    … …  
    22722358      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    22732359      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2360      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2361      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2362      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22742363      !!---------------------------------------------------------------------- 
    22752364      ! 
    22762365      ijpj   = 4 
     2366      ityp = -1 
    22772367      ijpjm1 = 3 
    22782368      ztab_2d(:,:) = 0.e0 
    … …  
    22852375      !                                     ! Build in procs of ncomm_north the znorthgloio_2d 
    22862376      itaille = jpi * ijpj 
    2287       CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        & 
    2288          &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2289       ! 
    2290       DO jr = 1, ndim_rank_north            ! recover the global north array 
    2291          iproc = nrank_north(jr) + 1 
    2292          ildi=nldit (iproc) 
    2293          ilei=nleit (iproc) 
    2294          iilb=nimppt(iproc) 
    2295          DO jj = 1, 4 
    2296             DO ji = ildi, ilei 
    2297                ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 
     2377      IF ( l_north_nogather ) THEN 
     2378         ! 
     2379         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2380         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2381         ! 
     2382         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2383            ij = jj - nlcj + ijpj 
     2384            DO ji = 1, nlci 
     2385               ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 
    22982386            END DO 
    22992387         END DO 
    2300       END DO 
     2388 
     2389         ! 
     2390         ! Set the exchange type in order to access the correct list of active neighbours 
     2391         ! 
     2392         SELECT CASE ( cd_type ) 
     2393            CASE ( 'T' , 'W' ) 
     2394               ityp = 1 
     2395            CASE ( 'U' ) 
     2396               ityp = 2 
     2397            CASE ( 'V' ) 
     2398               ityp = 3 
     2399            CASE ( 'F' ) 
     2400               ityp = 4 
     2401            CASE ( 'I' ) 
     2402               ityp = 5 
     2403            CASE DEFAULT 
     2404               ityp = -1                    ! Set a default value for unsupported types which  
     2405                                            ! will cause a fallback to the mpi_allgather method 
     2406         END SELECT 
     2407 
     2408         IF ( ityp .gt. 0 ) THEN 
     2409 
     2410            DO jr = 1,nsndto(ityp) 
     2411               CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
     2412            END DO 
     2413            DO jr = 1,nsndto(ityp) 
     2414               CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp)) 
     2415               iproc = isendto(jr,ityp) + 1 
     2416               ildi = nldit (iproc) 
     2417               ilei = nleit (iproc) 
     2418               iilb = nimppt(iproc) 
     2419               DO jj = 1, ijpj 
     2420                  DO ji = ildi, ilei 
     2421                     ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj) 
     2422                  END DO 
     2423               END DO 
     2424            END DO 
     2425            IF (l_isend) THEN 
     2426               DO jr = 1,nsndto(ityp) 
     2427                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2428               END DO 
     2429            ENDIF 
     2430 
     2431         ENDIF 
     2432 
     2433      ENDIF 
     2434 
     2435      IF ( ityp .lt. 0 ) THEN 
     2436         CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        & 
     2437            &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2438         ! 
     2439         DO jr = 1, ndim_rank_north            ! recover the global north array 
     2440            iproc = nrank_north(jr) + 1 
     2441            ildi = nldit (iproc) 
     2442            ilei = nleit (iproc) 
     2443            iilb = nimppt(iproc) 
     2444            DO jj = 1, ijpj 
     2445               DO ji = ildi, ilei 
     2446                  ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 
     2447               END DO 
     2448            END DO 
     2449         END DO 
     2450      ENDIF 
     2451      ! 
     2452      ! The ztab array has been either: 
     2453      !  a. Fully populated by the mpi_allgather operation or 
     2454      !  b. Had the active points for this domain and northern neighbours populated  
     2455      !     by peer to peer exchanges 
     2456      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2457      ! this domain will be identical. 
    23012458      ! 
    23022459      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition 
    … …  
    24802637 
    24812638   INTERFACE mpp_sum 
    2482       MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i 
     2639      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd 
    24832640   END INTERFACE 
    24842641   INTERFACE mpp_max 
    … …  
    24992656 
    25002657   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     2658   LOGICAL, PUBLIC            ::   ln_nnogather  = .FALSE.  !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    25012659   INTEGER :: ncomm_ice 
    25022660   !!---------------------------------------------------------------------- 
    … …  
    25522710   END SUBROUTINE mpp_sum_i 
    25532711 
     2712   SUBROUTINE mppsum_realdd( ytab, kcom ) 
     2713      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar 
     2714      INTEGER , INTENT( in  ), OPTIONAL :: kcom 
     2715      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab 
     2716   END SUBROUTINE mppsum_realdd 
     2717  
     2718   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
     2719      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab 
     2720      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array 
     2721      INTEGER , INTENT( in  ), OPTIONAL :: kcom 
     2722      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom 
     2723   END SUBROUTINE mppsum_a_realdd 
     2724 
    25542725   SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 
    25552726      REAL   , DIMENSION(:) :: parr 
    … …  
    26572828 
    26582829   SUBROUTINE mppstop 
    2659       WRITE(*,*) 'mppstop: You should not have seen this print! error?' 
     2830      WRITE(*,*) 'mppstop: You should not have seen this print if running in mpp mode! error?...' 
     2831      WRITE(*,*) 'mppstop: ..otherwise this is a stop condition raised by ctl_stop in single processor mode' 
     2832      STOP 
    26602833   END SUBROUTINE mppstop 
    26612834 
Note: See TracChangeset for help on using the changeset viewer.