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 7993 for branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Ignore:
Timestamp:
2017-05-02T13:29:51+02:00 (7 years ago)
Author:
frrh
Message:

Merge in missing revisions 6428:2477 inclusive and 6482 from nemo_v3_6_STABLE
branch. In ptic, this includes the fix for restartability of runoff fields in coupled
models. Evolution of coupled models will therefor be affected.

These changes donot affect evolution of the current stand-alone NEMO-CICE GO6
standard configuration.

Work and testing documented in Met Office GMED ticket 320.

Location:
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6486 r7993  
    1111   !!                            the BDY/OBC communications 
    1212   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add a C1D case   
     13   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_mpp_mpi 
     
    2425 
    2526   INTERFACE lbc_lnk_multi 
    26       MODULE PROCEDURE mpp_lnk_2d_9 
     27      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2728   END INTERFACE 
    2829 
     
    8081   END INTERFACE 
    8182 
     83   INTERFACE lbc_lnk_multi 
     84      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     85   END INTERFACE 
     86 
    8287   INTERFACE lbc_bdy_lnk 
    8388      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    8792      MODULE PROCEDURE lbc_lnk_2d_e 
    8893   END INTERFACE 
     94    
     95   TYPE arrayptr 
     96      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     97   END TYPE arrayptr 
     98   PUBLIC   arrayptr 
    8999 
    90100   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    91101   PUBLIC   lbc_lnk_e  
     102   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    92103   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    93104   PUBLIC   lbc_lnk_icb 
     
    171182      ! 
    172183   END SUBROUTINE lbc_lnk_2d 
     184    
     185   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     186      !! 
     187      INTEGER :: num_fields 
     188      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     189      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     190      !                                                               ! = T , U , V , F , W and I points 
     191      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     192      !                                                               ! =  1. , the sign is kept 
     193      ! 
     194      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     195      ! 
     196      DO ii = 1, num_fields 
     197        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     198      END DO      
     199      ! 
     200   END SUBROUTINE lbc_lnk_2d_multiple 
     201 
     202   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     203      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     204      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     205      !!--------------------------------------------------------------------- 
     206      ! Second 2D array on which the boundary condition is applied 
     207      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     208      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     209      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     210      ! define the nature of ptab array grid-points 
     211      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     212      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     213      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     214      ! =-1 the sign change across the north fold boundary 
     215      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     216      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     217      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     218      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     219      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     220      !! 
     221      !!--------------------------------------------------------------------- 
     222 
     223      !!The first array 
     224      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     225 
     226      !! Look if more arrays to process 
     227      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     228      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     229      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     230      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     231      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     232      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     233      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     234      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     235 
     236   END SUBROUTINE lbc_lnk_2d_9 
     237 
     238 
     239 
     240 
    173241 
    174242#else 
     
    372440      !     
    373441   END SUBROUTINE lbc_lnk_2d 
     442    
     443   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     444      !! 
     445      INTEGER :: num_fields 
     446      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     447      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     448      !                                                               ! = T , U , V , F , W and I points 
     449      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     450      !                                                               ! =  1. , the sign is kept 
     451      ! 
     452      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     453      ! 
     454      DO ii = 1, num_fields 
     455        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     456      END DO      
     457      ! 
     458   END SUBROUTINE lbc_lnk_2d_multiple 
     459 
     460   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     461      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     462      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     463      !!--------------------------------------------------------------------- 
     464      ! Second 2D array on which the boundary condition is applied 
     465      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     466      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     467      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     468      ! define the nature of ptab array grid-points 
     469      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     470      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     471      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     472      ! =-1 the sign change across the north fold boundary 
     473      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     474      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     475      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     476      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     477      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     478      !! 
     479      !!--------------------------------------------------------------------- 
     480 
     481      !!The first array 
     482      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     483 
     484      !! Look if more arrays to process 
     485      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     486      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     487      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     488      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     489      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     490      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     491      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     492      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     493 
     494   END SUBROUTINE lbc_lnk_2d_9 
     495 
    374496 
    375497#endif 
     
    441563   !!====================================================================== 
    442564END MODULE lbclnk 
     565 
  • branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6487 r7993  
    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   mppscatter, mppgather 
    7578   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7881   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7982   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     83   PUBLIC   mpprank 
    8084 
    8185   TYPE arrayptr 
    8286      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8387   END TYPE arrayptr 
     88   PUBLIC   arrayptr 
    8489    
    8590   !! * Interfaces 
     
    105110   INTERFACE mpp_maxloc 
    106111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     112   END INTERFACE 
     113 
     114   INTERFACE mpp_max_multiple 
     115      MODULE PROCEDURE mppmax_real_multiple 
    107116   END INTERFACE 
    108117 
     
    732741      ! ----------------------- 
    733742      ! 
    734       DO ii = 1 , num_fields 
    735743         !First Array 
    736          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    737             ! 
    738             SELECT CASE ( jpni ) 
    739             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    740             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    741             END SELECT 
    742             ! 
    743          ENDIF 
    744          ! 
    745       END DO 
     744      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     745         ! 
     746         SELECT CASE ( jpni ) 
     747         CASE ( 1 )     ;    
     748             DO ii = 1 , num_fields   
     749                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     750             END DO 
     751         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     752         END SELECT 
     753         ! 
     754      ENDIF 
     755        ! 
    746756       
    747757      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    16891699   END SUBROUTINE mppmax_real 
    16901700 
     1701   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1702      !!---------------------------------------------------------------------- 
     1703      !!                  ***  routine mppmax_real  *** 
     1704      !! 
     1705      !! ** Purpose :   Maximum 
     1706      !! 
     1707      !!---------------------------------------------------------------------- 
     1708      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1709      INTEGER , INTENT(in   )           ::   NUM 
     1710      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1711      !! 
     1712      INTEGER  ::   ierror, localcomm 
     1713      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1714      !!---------------------------------------------------------------------- 
     1715      ! 
     1716      CALL wrk_alloc(NUM , zwork) 
     1717      localcomm = mpi_comm_opa 
     1718      IF( PRESENT(kcom) )   localcomm = kcom 
     1719      ! 
     1720      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1721      ptab = zwork 
     1722      CALL wrk_dealloc(NUM , zwork) 
     1723      ! 
     1724   END SUBROUTINE mppmax_real_multiple 
     1725 
    16911726 
    16921727   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    25832618   END SUBROUTINE mpp_lbc_north_2d 
    25842619 
     2620   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2621      !!--------------------------------------------------------------------- 
     2622      !!                   ***  routine mpp_lbc_north_2d  *** 
     2623      !! 
     2624      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2625      !!              in mpp configuration in case of jpn1 > 1 
     2626      !!              (for multiple 2d arrays ) 
     2627      !! 
     2628      !! ** Method  :   North fold condition and mpp with more than one proc 
     2629      !!              in i-direction require a specific treatment. We gather 
     2630      !!              the 4 northern lines of the global domain on 1 processor 
     2631      !!              and apply lbc north-fold on this sub array. Then we 
     2632      !!              scatter the north fold array back to the processors. 
     2633      !! 
     2634      !!---------------------------------------------------------------------- 
     2635      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2636      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2637      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2638      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2639      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2640      !!                                                             ! =  1. , the sign is kept 
     2641      INTEGER ::   ji, jj, jr, jk 
     2642      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2643      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2644      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2645      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2646      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2647      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2648      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2649      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2650      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2651      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2652      INTEGER :: istatus(mpi_status_size) 
     2653      INTEGER :: iflag 
     2654      !!---------------------------------------------------------------------- 
     2655      ! 
     2656      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 
     2657      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2658      ! 
     2659      ijpj   = 4 
     2660      ijpjm1 = 3 
     2661      ! 
     2662       
     2663      DO jk = 1, num_fields 
     2664         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2665            ij = jj - nlcj + ijpj 
     2666            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2667         END DO 
     2668      END DO 
     2669      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2670      itaille = jpi * ijpj 
     2671                                                                   
     2672      IF ( l_north_nogather ) THEN 
     2673         ! 
     2674         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2675         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2676         ! 
     2677         ztabr(:,:,:) = 0 
     2678         ztabl(:,:,:) = 0 
     2679 
     2680         DO jk = 1, num_fields 
     2681            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2682               ij = jj - nlcj + ijpj 
     2683               DO ji = nfsloop, nfeloop 
     2684                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2685               END DO 
     2686            END DO 
     2687         END DO 
     2688 
     2689         DO jr = 1,nsndto 
     2690            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2691               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2692            ENDIF 
     2693         END DO 
     2694         DO jr = 1,nsndto 
     2695            iproc = nfipproc(isendto(jr),jpnj) 
     2696            IF(iproc .ne. -1) THEN 
     2697               ilei = nleit (iproc+1) 
     2698               ildi = nldit (iproc+1) 
     2699               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2700            ENDIF 
     2701            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2702              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2703              DO jk = 1 , num_fields 
     2704                 DO jj = 1, ijpj 
     2705                    DO ji = ildi, ilei 
     2706                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2707                    END DO 
     2708                 END DO 
     2709              END DO 
     2710            ELSE IF (iproc .eq. (narea-1)) THEN 
     2711              DO jk = 1, num_fields 
     2712                 DO jj = 1, ijpj 
     2713                    DO ji = ildi, ilei 
     2714                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2715                    END DO 
     2716                 END DO 
     2717              END DO 
     2718            ENDIF 
     2719         END DO 
     2720         IF (l_isend) THEN 
     2721            DO jr = 1,nsndto 
     2722               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2723                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2724               ENDIF 
     2725            END DO 
     2726         ENDIF 
     2727         ! 
     2728         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2729            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2730         END DO 
     2731         ! 
     2732         DO jk = 1, num_fields 
     2733            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2734               ij = jj - nlcj + ijpj 
     2735               DO ji = 1, nlci 
     2736                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2737               END DO 
     2738            END DO 
     2739         END DO 
     2740          
     2741         ! 
     2742      ELSE 
     2743         ! 
     2744         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2745            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2746         ! 
     2747         ztab(:,:,:) = 0.e0 
     2748         DO jk = 1, num_fields 
     2749            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2750               iproc = nrank_north(jr) + 1 
     2751               ildi = nldit (iproc) 
     2752               ilei = nleit (iproc) 
     2753               iilb = nimppt(iproc) 
     2754               DO jj = 1, ijpj 
     2755                  DO ji = ildi, ilei 
     2756                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2757                  END DO 
     2758               END DO 
     2759            END DO 
     2760         END DO 
     2761          
     2762         DO ji = 1, num_fields 
     2763            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2764         END DO 
     2765         ! 
     2766         DO jk = 1, num_fields 
     2767            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2768               ij = jj - nlcj + ijpj 
     2769               DO ji = 1, nlci 
     2770                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2771               END DO 
     2772            END DO 
     2773         END DO 
     2774         ! 
     2775         ! 
     2776      ENDIF 
     2777      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2778      DEALLOCATE( ztabl, ztabr ) 
     2779      ! 
     2780   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25852781 
    25862782   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
Note: See TracChangeset for help on using the changeset viewer.