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

Changeset 2882


Ignore:
Timestamp:
2011-09-30T17:57:57+02:00 (13 years ago)
Author:
acc
Message:

Branch 2011/dev_r2855_NOCS_mppsca. Code to avoid the use of MPI_ALLGATHER at the north fold. Prace investigations suggest this can improve scalability for large domain decompositions. This is a completion and replacement of work started on branch DEV_1879_mpp_sca. See #679

Location:
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/GYRE/EXP00/namelist

    r2715 r2882  
    695695                           !  buffer blocking send or immediate non-blocking sends, resp. 
    696696   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     697   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    697698   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1)      
    698699   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1)      
  • branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist

    r2715 r2882  
    695695                           !  buffer blocking send or immediate non-blocking sends, resp. 
    696696   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     697   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    697698   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1) 
    698699   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1) 
  • branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist

    r2715 r2882  
    709709                           !  buffer blocking send or immediate non-blocking sends, resp. 
    710710   nn_buffer   =   0       !  size in bytes of exported buffer ('B' case), 0 no exportation 
     711   ln_nnogather=  .false.  !  activate code to avoid mpi_allgather use at the northfold 
    711712   jpni        =   0       !  jpni   number of processors following i (set automatically if < 1) 
    712713   jpnj        =   0       !  jpnj   number of processors following j (set automatically if < 1) 
  • branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r2715 r2882  
    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_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r2731 r2882  
    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_req5            ! 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 ) 
     2252      IF ( l_north_nogather ) THEN 
     2253! 
     2254! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms) 
     2255! as being  involved in this process' northern boundary exchange 
     2256! 
     2257! First put local values into the global arraay 
     2258         DO jj = nlcj-ijpj+1, nlcj 
     2259           ij = jj - nlcj + ijpj 
     2260           DO ji = 1, nlci 
     2261             ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 
     2262           END DO 
     2263         END DO 
     2264 
     2265! 
     2266! Set the exchange type in order to access the correct list of active neighbours 
     2267! 
     2268         SELECT CASE ( cd_type ) 
     2269            CASE ( 'T' , 'W' ) 
     2270             ityp = 1 
     2271            CASE ( 'U' ) 
     2272             ityp = 2 
     2273            CASE ( 'V' ) 
     2274             ityp = 3 
     2275            CASE ( 'F' ) 
     2276             ityp = 4 
     2277            CASE ( 'I' ) 
     2278             ityp = 5 
     2279            CASE DEFAULT 
     2280! 
     2281! Set a default value for unsupported types which will cause a fallback to 
     2282! the mpi_allgather method 
     2283! 
     2284             ityp = -1 
     2285          END SELECT 
     2286          IF ( ityp .gt. 0 ) THEN 
     2287 
     2288           DO jr = 1,nsndto(ityp) 
     2289            CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) ) 
     2290           END DO 
     2291           DO jr = 1,nsndto(ityp) 
     2292            CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 
     2293            iproc = isendto(jr,ityp) + 1 
     2294            ildi=nldit (iproc) 
     2295            ilei=nleit (iproc) 
     2296            iilb=nimppt(iproc) 
     2297            DO jj = 1, 4 
     2298               DO ji = ildi, ilei 
     2299                  ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 
     2300               END DO 
     2301            END DO 
     2302           END DO 
     2303           IF(l_isend) THEN 
     2304              DO jr = 1,nsndto(ityp) 
     2305                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 
     2306              END DO 
     2307           ENDIF 
     2308 
     2309          ENDIF 
     2310 
     2311      ENDIF 
     2312 
     2313      IF ( ityp .lt. 0 ) THEN 
     2314         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
     2315            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    22262316      ! 
    22272317      !                                     ! 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) 
     2318         DO jr = 1, ndim_rank_north 
     2319            iproc = nrank_north(jr) + 1 
     2320            ildi  = nldit (iproc) 
     2321            ilei  = nleit (iproc) 
     2322            iilb  = nimppt(iproc) 
     2323            DO jj = 1, 4 
     2324               DO ji = ildi, ilei 
     2325                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 
     2326               END DO 
    22362327            END DO 
    22372328         END DO 
    2238       END DO 
     2329      ENDIF 
     2330      ! 
     2331      ! The ztab array has been either: 
     2332      !  a. Fully populated by the mpi_allgather operation or 
     2333      !  b. Had the active points for this domain and northern neighbours populated  
     2334      !     by peer to peer exchanges 
     2335      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2336      ! this domain will be identical. 
    22392337      ! 
    22402338      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
     
    22722370      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    22732371      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2372      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req5            ! for mpi_isend when avoiding mpi_allgather 
     2373      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2374      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22742375      !!---------------------------------------------------------------------- 
    22752376      ! 
    22762377      ijpj   = 4 
     2378      ityp = -1 
    22772379      ijpjm1 = 3 
    22782380      ztab_2d(:,:) = 0.e0 
     
    22852387      !                                     ! Build in procs of ncomm_north the znorthgloio_2d 
    22862388      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) 
     2389      IF ( l_north_nogather ) THEN 
     2390! 
     2391! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms)  
     2392! as being  involved in this process' northern boundary exchange 
     2393! 
     2394! First put local values into the global array 
     2395! 
     2396         DO jj = nlcj-ijpj+1, nlcj 
     2397           ij = jj - nlcj + ijpj 
     2398           DO ji = 1, nlci 
     2399             ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 
     2400           END DO 
     2401         END DO 
     2402 
     2403! 
     2404! Set the exchange type in order to access the correct list of active neighbours 
     2405! 
     2406         SELECT CASE ( cd_type ) 
     2407            CASE ( 'T' , 'W' ) 
     2408             ityp = 1 
     2409            CASE ( 'U' ) 
     2410             ityp = 2 
     2411            CASE ( 'V' ) 
     2412             ityp = 3 
     2413            CASE ( 'F' ) 
     2414             ityp = 4 
     2415            CASE ( 'I' ) 
     2416             ityp = 5 
     2417            CASE DEFAULT 
     2418! 
     2419! Set a default value for unsupported types which will cause a fallback to 
     2420! the mpi_allgather method 
     2421! 
     2422             ityp = -1 
     2423          END SELECT 
     2424 
     2425          IF ( ityp .gt. 0 ) THEN 
     2426 
     2427           DO jr = 1,nsndto(ityp) 
     2428            CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req5(jr) ) 
     2429           END DO 
     2430           DO jr = 1,nsndto(ityp) 
     2431            CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp)) 
     2432            iproc = isendto(jr,ityp) + 1 
     2433            ildi=nldit (iproc) 
     2434            ilei=nleit (iproc) 
     2435            iilb=nimppt(iproc) 
     2436            DO jj = 1, 4 
     2437               DO ji = ildi, ilei 
     2438                  ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj) 
     2439               END DO 
    22982440            END DO 
    2299          END DO 
    2300       END DO 
     2441           END DO 
     2442           IF(l_isend) THEN 
     2443              DO jr = 1,nsndto(ityp) 
     2444                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 
     2445              END DO 
     2446           ENDIF 
     2447 
     2448          ENDIF 
     2449 
     2450      ENDIF 
     2451 
     2452      IF ( ityp .lt. 0 ) THEN 
     2453       CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        & 
     2454          &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2455      ! 
     2456       DO jr = 1, ndim_rank_north            ! recover the global north array 
     2457          iproc = nrank_north(jr) + 1 
     2458          ildi=nldit (iproc) 
     2459          ilei=nleit (iproc) 
     2460          iilb=nimppt(iproc) 
     2461          DO jj = 1, 4 
     2462             DO ji = ildi, ilei 
     2463                ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 
     2464             END DO 
     2465          END DO 
     2466       END DO 
     2467      ENDIF 
     2468      ! 
     2469      ! The ztab array has been either: 
     2470      !  a. Fully populated by the mpi_allgather operation or 
     2471      !  b. Had the active points for this domain and northern neighbours populated  
     2472      !     by peer to peer exchanges 
     2473      ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2474      ! this domain will be identical. 
    23012475      ! 
    23022476      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition 
  • branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

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