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 6490 for trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Ignore:
Timestamp:
2016-04-20T16:55:58+02:00 (8 years ago)
Author:
mcastril
Message:

Merging of branch dev_r5546_CNRS19_HPC_scalability

Location:
trunk/NEMOGCM/NEMO/OPA_SRC/LBC
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6483 r6490  
    99   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
     11   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_mpp_mpi 
     
    2223 
    2324   INTERFACE lbc_lnk_multi 
    24       MODULE PROCEDURE mpp_lnk_2d_9 
     25      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2526   END INTERFACE 
    2627   ! 
     
    9091   END INTERFACE 
    9192   ! 
     93   INTERFACE lbc_lnk_multi 
     94      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     95   END INTERFACE 
     96 
    9297   INTERFACE lbc_bdy_lnk 
    9398      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    97102      MODULE PROCEDURE lbc_lnk_2d_e 
    98103   END INTERFACE 
     104    
     105   TYPE arrayptr 
     106      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     107   END TYPE arrayptr 
     108   PUBLIC   arrayptr 
    99109 
    100110   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    101111   PUBLIC   lbc_lnk_e     ! 
     112   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    102113   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    103114   PUBLIC   lbc_lnk_icb   ! 
     
    181192      ! 
    182193   END SUBROUTINE lbc_lnk_2d 
     194    
     195   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     196      !! 
     197      INTEGER :: num_fields 
     198      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     199      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     200      !                                                               ! = T , U , V , F , W and I points 
     201      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     202      !                                                               ! =  1. , the sign is kept 
     203      ! 
     204      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     205      ! 
     206      DO ii = 1, num_fields 
     207        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     208      END DO      
     209      ! 
     210   END SUBROUTINE lbc_lnk_2d_multiple 
     211 
     212   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     213      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     214      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     215      !!--------------------------------------------------------------------- 
     216      ! Second 2D array on which the boundary condition is applied 
     217      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     218      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     219      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     220      ! define the nature of ptab array grid-points 
     221      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     222      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     223      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     224      ! =-1 the sign change across the north fold boundary 
     225      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     226      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     227      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     228      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     229      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     230      !! 
     231      !!--------------------------------------------------------------------- 
     232 
     233      !!The first array 
     234      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     235 
     236      !! Look if more arrays to process 
     237      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     238      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     239      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     240      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     241      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     242      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     243      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     244      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     245 
     246   END SUBROUTINE lbc_lnk_2d_9 
     247 
     248 
     249 
     250 
    183251 
    184252#else 
     
    379447      !     
    380448   END SUBROUTINE lbc_lnk_2d 
     449    
     450   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     451      !! 
     452      INTEGER :: num_fields 
     453      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     454      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     455      !                                                               ! = T , U , V , F , W and I points 
     456      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     457      !                                                               ! =  1. , the sign is kept 
     458      ! 
     459      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     460      ! 
     461      DO ii = 1, num_fields 
     462        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     463      END DO      
     464      ! 
     465   END SUBROUTINE lbc_lnk_2d_multiple 
     466 
     467   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     468      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     469      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     470      !!--------------------------------------------------------------------- 
     471      ! Second 2D array on which the boundary condition is applied 
     472      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     473      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     474      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     475      ! define the nature of ptab array grid-points 
     476      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     477      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     478      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     479      ! =-1 the sign change across the north fold boundary 
     480      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     481      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     482      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     483      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     484      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     485      !! 
     486      !!--------------------------------------------------------------------- 
     487 
     488      !!The first array 
     489      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     490 
     491      !! Look if more arrays to process 
     492      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     493      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     494      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     495      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     496      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     497      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     498      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     499      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     500 
     501   END SUBROUTINE lbc_lnk_2d_9 
     502 
    381503 
    382504#endif 
     
    448570   !!====================================================================== 
    449571END MODULE lbclnk 
     572 
  • trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6483 r6490  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
     
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
     
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7578   PUBLIC   mppscatter, mppgather 
     
    7982   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    8083   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     84   PUBLIC   mpprank 
    8185 
    8286   TYPE arrayptr 
    8387      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8488   END TYPE arrayptr 
     89   PUBLIC   arrayptr 
    8590    
    8691   !! * Interfaces 
     
    106111   INTERFACE mpp_maxloc 
    107112      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     113   END INTERFACE 
     114 
     115   INTERFACE mpp_max_multiple 
     116      MODULE PROCEDURE mppmax_real_multiple 
    108117   END INTERFACE 
    109118 
     
    726735      ! ----------------------- 
    727736      ! 
    728       DO ii = 1 , num_fields 
    729737         !First Array 
    730          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    731             ! 
    732             SELECT CASE ( jpni ) 
    733             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    734             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    735             END SELECT 
    736             ! 
    737          ENDIF 
    738          ! 
    739       END DO 
     738      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     739         ! 
     740         SELECT CASE ( jpni ) 
     741         CASE ( 1 )     ;    
     742             DO ii = 1 , num_fields   
     743                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     744             END DO 
     745         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     746         END SELECT 
     747         ! 
     748      ENDIF 
     749        ! 
    740750      ! 
    741751      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    20192029   END SUBROUTINE mppmax_real 
    20202030 
     2031   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     2032      !!---------------------------------------------------------------------- 
     2033      !!                  ***  routine mppmax_real  *** 
     2034      !! 
     2035      !! ** Purpose :   Maximum 
     2036      !! 
     2037      !!---------------------------------------------------------------------- 
     2038      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     2039      INTEGER , INTENT(in   )           ::   NUM 
     2040      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     2041      !! 
     2042      INTEGER  ::   ierror, localcomm 
     2043      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     2044      !!---------------------------------------------------------------------- 
     2045      ! 
     2046      CALL wrk_alloc(NUM , zwork) 
     2047      localcomm = mpi_comm_opa 
     2048      IF( PRESENT(kcom) )   localcomm = kcom 
     2049      ! 
     2050      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     2051      ptab = zwork 
     2052      CALL wrk_dealloc(NUM , zwork) 
     2053      ! 
     2054   END SUBROUTINE mppmax_real_multiple 
     2055 
    20212056 
    20222057   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    29122947   END SUBROUTINE mpp_lbc_north_2d 
    29132948 
     2949   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2950      !!--------------------------------------------------------------------- 
     2951      !!                   ***  routine mpp_lbc_north_2d  *** 
     2952      !! 
     2953      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2954      !!              in mpp configuration in case of jpn1 > 1 
     2955      !!              (for multiple 2d arrays ) 
     2956      !! 
     2957      !! ** Method  :   North fold condition and mpp with more than one proc 
     2958      !!              in i-direction require a specific treatment. We gather 
     2959      !!              the 4 northern lines of the global domain on 1 processor 
     2960      !!              and apply lbc north-fold on this sub array. Then we 
     2961      !!              scatter the north fold array back to the processors. 
     2962      !! 
     2963      !!---------------------------------------------------------------------- 
     2964      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2965      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2966      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2967      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2968      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2969      !!                                                             ! =  1. , the sign is kept 
     2970      INTEGER ::   ji, jj, jr, jk 
     2971      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2972      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2973      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2974      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2975      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2976      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2977      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2978      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2979      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2980      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2981      INTEGER :: istatus(mpi_status_size) 
     2982      INTEGER :: iflag 
     2983      !!---------------------------------------------------------------------- 
     2984      ! 
     2985      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2986      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2987      ! 
     2988      ijpj   = 4 
     2989      ijpjm1 = 3 
     2990      ! 
     2991       
     2992      DO jk = 1, num_fields 
     2993         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2994            ij = jj - nlcj + ijpj 
     2995            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2996         END DO 
     2997      END DO 
     2998      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2999      itaille = jpi * ijpj 
     3000                                                                   
     3001      IF ( l_north_nogather ) THEN 
     3002         ! 
     3003         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     3004         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     3005         ! 
     3006         ztabr(:,:,:) = 0 
     3007         ztabl(:,:,:) = 0 
     3008 
     3009         DO jk = 1, num_fields 
     3010            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     3011               ij = jj - nlcj + ijpj 
     3012               DO ji = nfsloop, nfeloop 
     3013                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     3014               END DO 
     3015            END DO 
     3016         END DO 
     3017 
     3018         DO jr = 1,nsndto 
     3019            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3020               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     3021            ENDIF 
     3022         END DO 
     3023         DO jr = 1,nsndto 
     3024            iproc = nfipproc(isendto(jr),jpnj) 
     3025            IF(iproc .ne. -1) THEN 
     3026               ilei = nleit (iproc+1) 
     3027               ildi = nldit (iproc+1) 
     3028               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     3029            ENDIF 
     3030            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     3031              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     3032              DO jk = 1 , num_fields 
     3033                 DO jj = 1, ijpj 
     3034                    DO ji = ildi, ilei 
     3035                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     3036                    END DO 
     3037                 END DO 
     3038              END DO 
     3039            ELSE IF (iproc .eq. (narea-1)) THEN 
     3040              DO jk = 1, num_fields 
     3041                 DO jj = 1, ijpj 
     3042                    DO ji = ildi, ilei 
     3043                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     3044                    END DO 
     3045                 END DO 
     3046              END DO 
     3047            ENDIF 
     3048         END DO 
     3049         IF (l_isend) THEN 
     3050            DO jr = 1,nsndto 
     3051               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3052                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     3053               ENDIF 
     3054            END DO 
     3055         ENDIF 
     3056         ! 
     3057         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     3058            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     3059         END DO 
     3060         ! 
     3061         DO jk = 1, num_fields 
     3062            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3063               ij = jj - nlcj + ijpj 
     3064               DO ji = 1, nlci 
     3065                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     3066               END DO 
     3067            END DO 
     3068         END DO 
     3069          
     3070         ! 
     3071      ELSE 
     3072         ! 
     3073         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     3074            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     3075         ! 
     3076         ztab(:,:,:) = 0.e0 
     3077         DO jk = 1, num_fields 
     3078            DO jr = 1, ndim_rank_north            ! recover the global north array 
     3079               iproc = nrank_north(jr) + 1 
     3080               ildi = nldit (iproc) 
     3081               ilei = nleit (iproc) 
     3082               iilb = nimppt(iproc) 
     3083               DO jj = 1, ijpj 
     3084                  DO ji = ildi, ilei 
     3085                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     3086                  END DO 
     3087               END DO 
     3088            END DO 
     3089         END DO 
     3090          
     3091         DO ji = 1, num_fields 
     3092            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     3093         END DO 
     3094         ! 
     3095         DO jk = 1, num_fields 
     3096            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3097               ij = jj - nlcj + ijpj 
     3098               DO ji = 1, nlci 
     3099                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     3100               END DO 
     3101            END DO 
     3102         END DO 
     3103         ! 
     3104         ! 
     3105      ENDIF 
     3106      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     3107      DEALLOCATE( ztabl, ztabr ) 
     3108      ! 
     3109   END SUBROUTINE mpp_lbc_north_2d_multiple 
    29143110 
    29153111   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
Note: See TracChangeset for help on using the changeset viewer.