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 3009 for branches – NEMO

Changeset 3009 for branches


Ignore:
Timestamp:
2011-10-27T13:35:36+02:00 (12 years ago)
Author:
acc
Message:

Branch dev_NOC_2011_MERGE. #874. Step 7: Merge in changes from 2011/dev_r2855_NOCS_mppsca branch

Location:
branches/2011/dev_NOC_2011_MERGE
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • branches/2011/dev_NOC_2011_MERGE/DOC/TexFiles/Chapters/Chap_MISC.tex

    r2541 r3009  
    253253Note this implementation may be sensitive to the optimization level.  
    254254 
     255\subsection{MPP scalability} 
     256\label{MISC_mppsca} 
     257 
     258The default method of communicating values across the north-fold in distributed memory applications 
     259(\key{mpp\_mpi}) uses a \textsc{MPI\_ALLGATHER} function to exchange values from each processing 
     260region in the northern row with every other processing region in the northern row. This enables a 
     261global width array containing the top 4 rows to be collated on every northern row processor and then 
     262folded with a simple algorithm. Although conceptually simple, this "All to All" communication will 
     263hamper performance scalability for large numbers of northern row processors. From version 3.4 
     264onwards an alternative method is available which only performs direct "Peer to Peer" communications 
     265between each processor and its immediate "neighbours" across the fold line. This is achieved by 
     266using the default \textsc{MPI\_ALLGATHER} method during initialisation to help identify the "active" 
     267neighbours. Stored lists of these neighbours are then used in all subsequent north-fold exchanges to 
     268restrict exchanges to those between associated regions. The collated global width array for each 
     269region is thus only partially filled but is guaranteed to be set at all the locations actually 
     270required by each individual for the fold operation. This alternative method should give identical 
     271results to the default \textsc{ALLGATHER} method and is recommended for large values of \np{jpni}. 
     272The new method is activated by setting \np{ln\_nnogather} to be true ({\bf nammpp}). The 
     273reproducibility of results using the two methods should be confirmed for each new, non-reference 
     274configuration. 
    255275 
    256276% ================================================================ 
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/GYRE/EXP00/namelist

    r2986 r3009  
    697697                           !  buffer blocking send or immediate non-blocking sends, resp. 
    698698   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     699   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    699700   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1)      
    700701   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1)      
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist

    r2986 r3009  
    697697                           !  buffer blocking send or immediate non-blocking sends, resp. 
    698698   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     699   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    699700   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1) 
    700701   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1) 
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist

    r2986 r3009  
    711711                           !  buffer blocking send or immediate non-blocking sends, resp. 
    712712   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     713   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    713714   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1) 
    714715   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1) 
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r2715 r3009  
    236236               END DO 
    237237            END DO 
     238         CASE ( 'J' )                                     ! first ice U-V point 
     239            DO jl =0, ipr2dj 
     240               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
     241               DO ji = 3, jpiglo 
     242                  iju = jpiglo - ji + 3 
     243                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
     244               END DO 
     245            END DO 
     246         CASE ( 'K' )                                     ! second ice U-V point 
     247            DO jl =0, ipr2dj 
     248               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
     249               DO ji = 3, jpiglo 
     250                  iju = jpiglo - ji + 3 
     251                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
     252               END DO 
     253            END DO 
    238254         END SELECT 
    239255         ! 
     
    285301               END DO 
    286302            END DO 
     303         CASE ( 'J' )                                  ! first ice U-V point 
     304            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
     305            DO jl = 0, ipr2dj 
     306               DO ji = 2 , jpiglo-1 
     307                  ijt = jpiglo - ji + 2 
     308                  pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) 
     309               END DO 
     310            END DO 
     311         CASE ( 'K' )                                  ! second ice U-V point 
     312            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
     313            DO jl = 0, ipr2dj 
     314               DO ji = 2 , jpiglo-1 
     315                  ijt = jpiglo - ji + 2 
     316                  pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) 
     317               END DO 
     318            END DO 
    287319         END SELECT 
    288320         ! 
     
    298330            pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    299331            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     332         CASE ( 'J' )                                   ! first ice U-V point 
     333            pt2d(:, 1:1-ipr2dj     ) = 0.e0 
     334            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     335         CASE ( 'K' )                                   ! second ice U-V point 
     336            pt2d(:, 1:1-ipr2dj     ) = 0.e0 
     337            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    300338         END SELECT 
    301339         ! 
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r2731 r3009  
    164164   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztab, znorthloc 
    165165   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE   ::   znorthgloio 
     166   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   zfoldwk      ! Workspace for message transfers avoiding mpi_allgather 
    166167 
    167168   ! Arrays used in mpp_lbc_north_2d() 
    168169   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_2d, znorthloc_2d 
    169170   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_2d 
     171   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   zfoldwk_2d    ! Workspace for message transfers avoiding mpi_allgather 
    170172 
    171173   ! Arrays used in mpp_lbc_north_e() 
     
    173175   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_e 
    174176 
     177   ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 
     178   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours 
     179   INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges  
     180   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto 
     181   INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto 
     182   LOGICAL, PUBLIC                                  ::   ln_nnogather     = .FALSE.  ! namelist control of northfold comms 
     183   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms 
     184   INTEGER, PUBLIC                                  ::   ityp 
    175185   !!---------------------------------------------------------------------- 
    176186   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     
    203213         ! 
    204214         &      ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) ,                        & 
     215         &      zfoldwk(jpi,4,jpk) ,                                                                             & 
    205216         ! 
    206217         &      ztab_2d(jpiglo,4)  , znorthloc_2d(jpi,4)  , znorthgloio_2d(jpi,4,jpni)  ,                        & 
     218         &      zfoldwk_2d(jpi,4)  ,                                                                             & 
    207219         ! 
    208220         &      ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) ,   & 
     
    232244      LOGICAL ::   mpi_was_called 
    233245      ! 
    234       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij 
     246      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather 
    235247      !!---------------------------------------------------------------------- 
    236248      ! 
     
    269281         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij; ii = ii +1 
    270282      END IF 
     283 
     284      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    271285 
    272286      CALL mpi_initialized ( mpi_was_called, code ) 
     
    441455      CASE ( -1 ) 
    442456         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
    443          CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 
     457         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
    444458         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    445459      CASE ( 0 ) 
    446460         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    447461         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 ) 
     462         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     463         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    450464         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    451465         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    452466      CASE ( 1 ) 
    453467         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    454          CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 
     468         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    455469         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    456470      END SELECT 
     
    494508      CASE ( -1 ) 
    495509         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    496          CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 
     510         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
    497511         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    498512      CASE ( 0 ) 
    499513         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    500514         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 ) 
     515         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     516         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    503517         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    504518         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    505519      CASE ( 1 )  
    506520         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    507          CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 
     521         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    508522         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    509523      END SELECT 
     
    635649      CASE ( -1 ) 
    636650         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    637          CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     651         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    638652         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    639653      CASE ( 0 ) 
    640654         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    641655         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 ) 
     656         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     657         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    644658         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    645659         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    646660      CASE ( 1 ) 
    647661         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    648          CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     662         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    649663         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    650664      END SELECT 
     
    688702      CASE ( -1 ) 
    689703         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    690          CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     704         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    691705         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    692706      CASE ( 0 ) 
    693707         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    694708         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 ) 
     709         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     710         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    697711         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    698712         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    699713      CASE ( 1 ) 
    700714         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    701          CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
     715         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    702716         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    703717      END SELECT 
     
    816830      CASE ( -1 ) 
    817831         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    818          CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 
     832         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
    819833         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    820834      CASE ( 0 ) 
    821835         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    822836         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 ) 
     837         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
     838         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    825839         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    826840         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    827841      CASE ( 1 ) 
    828842         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    829          CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 
     843         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    830844         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    831845      END SELECT 
     
    875889      CASE ( -1 ) 
    876890         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    877          CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 
     891         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
    878892         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    879893      CASE ( 0 ) 
    880894         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    881895         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 ) 
     896         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
     897         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    884898         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    885899         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    886900      CASE ( 1 )  
    887901         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    888          CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 
     902         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    889903         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    890904      END SELECT 
     
    10191033      CASE ( -1 ) 
    10201034         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 
    1021          CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 
     1035         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
    10221036         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10231037      CASE ( 0 ) 
    10241038         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    10251039         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 ) 
     1040         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
     1041         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10281042         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10291043         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10301044      CASE ( 1 ) 
    10311045         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    1032          CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 
     1046         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10331047         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10341048      END SELECT 
     
    10721086      CASE ( -1 ) 
    10731087         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 
    1074          CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 
     1088         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
    10751089         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10761090      CASE ( 0 ) 
    10771091         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    10781092         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 ) 
     1093         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
     1094         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10811095         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10821096         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10831097      CASE ( 1 ) 
    10841098         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    1085          CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 
     1099         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10861100         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10871101      END SELECT 
     
    11381152 
    11391153 
    1140    SUBROUTINE mpprecv( ktyp, pmess, kbytes ) 
     1154   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 
    11411155      !!---------------------------------------------------------------------- 
    11421156      !!                  ***  routine mpprecv  *** 
     
    11481162      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
    11491163      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     1164      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number  
    11501165      !! 
    11511166      INTEGER :: istatus(mpi_status_size) 
    11521167      INTEGER :: iflag 
    1153       !!---------------------------------------------------------------------- 
    1154       ! 
    1155       CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag ) 
     1168      INTEGER :: use_source 
     1169      !!---------------------------------------------------------------------- 
     1170      ! 
     1171 
     1172      ! If a specific process number has been passed to the receive call,  
     1173      ! use that one. Default is to use mpi_any_source 
     1174      use_source=mpi_any_source 
     1175      if(present(ksource)) then 
     1176         use_source=ksource 
     1177      end if 
     1178 
     1179      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 
    11561180      ! 
    11571181   END SUBROUTINE mpprecv 
     
    18331857         IF( nbondi == -1 ) THEN 
    18341858            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
    1835             CALL mpprecv( 1, t2ew(1,1,2), imigr ) 
     1859            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    18361860            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18371861         ELSEIF( nbondi == 0 ) THEN 
    18381862            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    18391863            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 ) 
     1864            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1865            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18421866            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18431867            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18441868         ELSEIF( nbondi == 1 ) THEN 
    18451869            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1846             CALL mpprecv( 2, t2we(1,1,2), imigr ) 
     1870            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18471871            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18481872         ENDIF 
     
    18791903         IF( nbondj == -1 ) THEN 
    18801904            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
    1881             CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
     1905            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    18821906            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18831907         ELSEIF( nbondj == 0 ) THEN 
    18841908            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    18851909            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 ) 
     1910            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1911            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    18881912            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18891913            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18901914         ELSEIF( nbondj == 1 ) THEN 
    18911915            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
    1892             CALL mpprecv( 4, t2sn(1,1,2), imigr) 
     1916            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso) 
    18931917            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18941918         ENDIF 
     
    22092233      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    22102234      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2235      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2236      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2237      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22112238      !!---------------------------------------------------------------------- 
    22122239      !    
    22132240      ijpj   = 4 
     2241      ityp = -1 
    22142242      ijpjm1 = 3 
    22152243      ztab(:,:,:) = 0.e0 
     
    22222250      !                                     ! Build in procs of ncomm_north the znorthgloio 
    22232251      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) 
     2252      IF ( l_north_nogather ) THEN 
     2253         ! 
     2254         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2255         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2256         ! 
     2257         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2258            ij = jj - nlcj + ijpj 
     2259            DO ji = 1, nlci 
     2260               ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 
    22362261            END DO 
    22372262         END DO 
    2238       END DO 
     2263 
     2264         ! 
     2265         ! Set the exchange type in order to access the correct list of active neighbours 
     2266         ! 
     2267         SELECT CASE ( cd_type ) 
     2268            CASE ( 'T' , 'W' ) 
     2269               ityp = 1 
     2270            CASE ( 'U' ) 
     2271               ityp = 2 
     2272            CASE ( 'V' ) 
     2273               ityp = 3 
     2274            CASE ( 'F' ) 
     2275               ityp = 4 
     2276            CASE ( 'I' ) 
     2277               ityp = 5 
     2278            CASE DEFAULT 
     2279               ityp = -1                    ! Set a default value for unsupported types which  
     2280                                            ! will cause a fallback to the mpi_allgather method 
     2281         END SELECT 
     2282         IF ( ityp .gt. 0 ) THEN 
     2283 
     2284            DO jr = 1,nsndto(ityp) 
     2285               CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
     2286            END DO 
     2287            DO jr = 1,nsndto(ityp) 
     2288               CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 
     2289               iproc = isendto(jr,ityp) + 1 
     2290               ildi = nldit (iproc) 
     2291               ilei = nleit (iproc) 
     2292               iilb = nimppt(iproc) 
     2293               DO jj = 1, ijpj 
     2294                  DO ji = ildi, ilei 
     2295                     ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 
     2296                  END DO 
     2297               END DO 
     2298            END DO 
     2299            IF (l_isend) THEN 
     2300               DO jr = 1,nsndto(ityp) 
     2301                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2302               END DO 
     2303            ENDIF 
     2304 
     2305         ENDIF 
     2306 
     2307      ENDIF 
     2308 
     2309      IF ( ityp .lt. 0 ) THEN 
     2310         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
     2311            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2312         ! 
     2313         DO jr = 1, ndim_rank_north         ! recover the global north array 
     2314            iproc = nrank_north(jr) + 1 
     2315            ildi  = nldit (iproc) 
     2316            ilei  = nleit (iproc) 
     2317            iilb  = nimppt(iproc) 
     2318            DO jj = 1, ijpj 
     2319               DO ji = ildi, ilei 
     2320                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2321               END DO 
     2322            END DO 
     2323         END DO 
     2324      ENDIF 
     2325      ! 
     2326      ! The ztab array has been either: 
     2327      !  a. Fully populated by the mpi_allgather operation or 
     2328      !  b. Had the active points for this domain and northern neighbours populated  
     2329      !     by peer to peer exchanges 
     2330      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2331      ! this domain will be identical. 
    22392332      ! 
    22402333      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
     
    22722365      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    22732366      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2367      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2368      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2369      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22742370      !!---------------------------------------------------------------------- 
    22752371      ! 
    22762372      ijpj   = 4 
     2373      ityp = -1 
    22772374      ijpjm1 = 3 
    22782375      ztab_2d(:,:) = 0.e0 
     
    22852382      !                                     ! Build in procs of ncomm_north the znorthgloio_2d 
    22862383      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) 
     2384      IF ( l_north_nogather ) THEN 
     2385         ! 
     2386         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2387         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2388         ! 
     2389         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2390            ij = jj - nlcj + ijpj 
     2391            DO ji = 1, nlci 
     2392               ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 
    22982393            END DO 
    22992394         END DO 
    2300       END DO 
     2395 
     2396         ! 
     2397         ! Set the exchange type in order to access the correct list of active neighbours 
     2398         ! 
     2399         SELECT CASE ( cd_type ) 
     2400            CASE ( 'T' , 'W' ) 
     2401               ityp = 1 
     2402            CASE ( 'U' ) 
     2403               ityp = 2 
     2404            CASE ( 'V' ) 
     2405               ityp = 3 
     2406            CASE ( 'F' ) 
     2407               ityp = 4 
     2408            CASE ( 'I' ) 
     2409               ityp = 5 
     2410            CASE DEFAULT 
     2411               ityp = -1                    ! Set a default value for unsupported types which  
     2412                                            ! will cause a fallback to the mpi_allgather method 
     2413         END SELECT 
     2414 
     2415         IF ( ityp .gt. 0 ) THEN 
     2416 
     2417            DO jr = 1,nsndto(ityp) 
     2418               CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
     2419            END DO 
     2420            DO jr = 1,nsndto(ityp) 
     2421               CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp)) 
     2422               iproc = isendto(jr,ityp) + 1 
     2423               ildi = nldit (iproc) 
     2424               ilei = nleit (iproc) 
     2425               iilb = nimppt(iproc) 
     2426               DO jj = 1, ijpj 
     2427                  DO ji = ildi, ilei 
     2428                     ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj) 
     2429                  END DO 
     2430               END DO 
     2431            END DO 
     2432            IF (l_isend) THEN 
     2433               DO jr = 1,nsndto(ityp) 
     2434                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2435               END DO 
     2436            ENDIF 
     2437 
     2438         ENDIF 
     2439 
     2440      ENDIF 
     2441 
     2442      IF ( ityp .lt. 0 ) THEN 
     2443         CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        & 
     2444            &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2445         ! 
     2446         DO jr = 1, ndim_rank_north            ! recover the global north array 
     2447            iproc = nrank_north(jr) + 1 
     2448            ildi = nldit (iproc) 
     2449            ilei = nleit (iproc) 
     2450            iilb = nimppt(iproc) 
     2451            DO jj = 1, ijpj 
     2452               DO ji = ildi, ilei 
     2453                  ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 
     2454               END DO 
     2455            END DO 
     2456         END DO 
     2457      ENDIF 
     2458      ! 
     2459      ! The ztab array has been either: 
     2460      !  a. Fully populated by the mpi_allgather operation or 
     2461      !  b. Had the active points for this domain and northern neighbours populated  
     2462      !     by peer to peer exchanges 
     2463      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2464      ! this domain will be identical. 
    23012465      ! 
    23022466      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition 
  • branches/2011/dev_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2986 r3009  
    293293                            CALL     dom_init   ! Domain 
    294294 
     295      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined) 
     296 
    295297      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
    296298 
     
    622624   END SUBROUTINE factorise 
    623625 
     626   SUBROUTINE nemo_northcomms 
     627      !!====================================================================== 
     628      !!                     ***  ROUTINE  nemo_northcomms  *** 
     629      !! nemo_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging 
     630      !!===================================================================== 
     631      !!---------------------------------------------------------------------- 
     632      !!  
     633      !! ** Purpose :   Initialization of the northern neighbours lists. 
     634      !!---------------------------------------------------------------------- 
     635      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)  
     636      !!---------------------------------------------------------------------- 
     637 
     638      INTEGER ::   ji, jj, jk, ij, jtyp    ! dummy loop indices 
     639      INTEGER ::   ijpj                    ! number of rows involved in north-fold exchange 
     640      INTEGER ::   northcomms_alloc        ! allocate return status 
     641      REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) ::   znnbrs     ! workspace 
     642      LOGICAL,  ALLOCATABLE, DIMENSION ( : )   ::   lrankset   ! workspace 
     643 
     644      IF(lwp) WRITE(numout,*) 
     645      IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 
     646      IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     647 
     648      !!---------------------------------------------------------------------- 
     649      ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 
     650      ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 
     651      IF( northcomms_alloc /= 0 ) THEN 
     652         WRITE(numout,cform_war) 
     653         WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 
     654         CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 
     655      ENDIF 
     656      nsndto = 0 
     657      isendto = -1 
     658      ijpj   = 4 
     659      ! 
     660      ! This routine has been called because ln_nnogather has been set true ( nammpp ) 
     661      ! However, these first few exchanges have to use the mpi_allgather method to 
     662      ! establish the neighbour lists to use in subsequent peer to peer exchanges. 
     663      ! Consequently, set l_north_nogather to be false here and set it true only after 
     664      ! the lists have been established. 
     665      ! 
     666      l_north_nogather = .FALSE. 
     667      ! 
     668      ! Exchange and store ranks on northern rows 
     669 
     670      DO jtyp = 1,4 
     671 
     672         lrankset = .FALSE. 
     673         znnbrs = narea 
     674         SELECT CASE (jtyp) 
     675            CASE(1) 
     676               CALL lbc_lnk( znnbrs, 'T', 1. )      ! Type 1: T,W-points 
     677            CASE(2) 
     678               CALL lbc_lnk( znnbrs, 'U', 1. )      ! Type 2: U-point 
     679            CASE(3) 
     680               CALL lbc_lnk( znnbrs, 'V', 1. )      ! Type 3: V-point 
     681            CASE(4) 
     682               CALL lbc_lnk( znnbrs, 'F', 1. )      ! Type 4: F-point 
     683         END SELECT 
     684 
     685         IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 
     686            DO jj = nlcj-ijpj+1, nlcj 
     687               ij = jj - nlcj + ijpj 
     688               DO ji = 1,jpi 
     689                  IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 
     690               &     lrankset(INT(znnbrs(ji,jj))) = .true. 
     691               END DO 
     692            END DO 
     693 
     694            DO jj = 1,jpnij 
     695               IF ( lrankset(jj) ) THEN 
     696                  nsndto(jtyp) = nsndto(jtyp) + 1 
     697                  IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 
     698                     CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 
     699                  &                 ' jpmaxngh will need to be increased ') 
     700                  ENDIF 
     701                  isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank 
     702               ENDIF 
     703            END DO 
     704         ENDIF 
     705 
     706      END DO 
     707 
     708      ! 
     709      ! Type 5: I-point 
     710      ! 
     711      ! ICE point exchanges may involve some averaging. The neighbours list is 
     712      ! built up using two exchanges to ensure that the whole stencil is covered. 
     713      ! lrankset should not be reset between these 'J' and 'K' point exchanges 
     714 
     715      jtyp = 5 
     716      lrankset = .FALSE. 
     717      znnbrs = narea  
     718      CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 
     719 
     720      IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 
     721         DO jj = nlcj-ijpj+1, nlcj 
     722            ij = jj - nlcj + ijpj 
     723            DO ji = 1,jpi 
     724               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 
     725            &     lrankset(INT(znnbrs(ji,jj))) = .true. 
     726         END DO 
     727        END DO 
     728      ENDIF 
     729 
     730      znnbrs = narea  
     731      CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 
     732 
     733      IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN 
     734         DO jj = nlcj-ijpj+1, nlcj 
     735            ij = jj - nlcj + ijpj 
     736            DO ji = 1,jpi 
     737               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND.  INT(znnbrs(ji,jj)) .NE. narea ) & 
     738            &       lrankset( INT(znnbrs(ji,jj))) = .true. 
     739            END DO 
     740         END DO 
     741 
     742         DO jj = 1,jpnij 
     743            IF ( lrankset(jj) ) THEN 
     744               nsndto(jtyp) = nsndto(jtyp) + 1 
     745               IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 
     746                  CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 
     747               &                 ' jpmaxngh will need to be increased ') 
     748               ENDIF 
     749               isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank 
     750            ENDIF 
     751         END DO 
     752         ! 
     753         ! For northern row areas, set l_north_nogather so that all subsequent exchanges  
     754         ! can use peer to peer communications at the north fold 
     755         ! 
     756         l_north_nogather = .TRUE. 
     757         ! 
     758      ENDIF 
     759      DEALLOCATE( znnbrs ) 
     760      DEALLOCATE( lrankset ) 
     761 
     762   END SUBROUTINE nemo_northcomms 
    624763   !!====================================================================== 
    625764END MODULE nemogcm 
Note: See TracChangeset for help on using the changeset viewer.