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

Ignore:
Timestamp:
2016-04-19T17:11:00+02:00 (8 years ago)
Author:
mcastril
Message:

Revert last changes in the trunk

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

Legend:

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

    r6478 r6483  
    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   
    1211   !!---------------------------------------------------------------------- 
    1312#if defined key_mpp_mpi 
     
    2322 
    2423   INTERFACE lbc_lnk_multi 
    25       MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
     24      MODULE PROCEDURE mpp_lnk_2d_9 
    2625   END INTERFACE 
    2726   ! 
     
    9190   END INTERFACE 
    9291   ! 
    93    INTERFACE lbc_lnk_multi 
    94       MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
    95    END INTERFACE 
    96  
    9792   INTERFACE lbc_bdy_lnk 
    9893      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    10297      MODULE PROCEDURE lbc_lnk_2d_e 
    10398   END INTERFACE 
    104     
    105    TYPE arrayptr 
    106       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    107    END TYPE arrayptr 
    108    PUBLIC   arrayptr 
    10999 
    110100   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    111101   PUBLIC   lbc_lnk_e     ! 
    112    PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    113102   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    114103   PUBLIC   lbc_lnk_icb   ! 
     
    192181      ! 
    193182   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  
    251183 
    252184#else 
     
    447379      !     
    448380   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  
    503381 
    504382#endif 
     
    570448   !!====================================================================== 
    571449END MODULE lbclnk 
    572  
  • trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6478 r6483  
    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'  
    2726   !!---------------------------------------------------------------------- 
    2827 
     
    6362   USE lbcnfd         ! north fold treatment 
    6463   USE in_out_manager ! I/O manager 
    65    USE wrk_nemo       ! work arrays 
    6664 
    6765   IMPLICIT NONE 
     
    7270   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7371   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    74    PUBLIC   mpp_max_multiple 
    7572   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    76    PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
     73   PUBLIC   mpp_lnk_2d_9  
    7774   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7875   PUBLIC   mppscatter, mppgather 
     
    8279   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    8380   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    84    PUBLIC   mpprank 
    8581 
    8682   TYPE arrayptr 
    8783      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8884   END TYPE arrayptr 
    89    PUBLIC   arrayptr 
    9085    
    9186   !! * Interfaces 
     
    111106   INTERFACE mpp_maxloc 
    112107      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113    END INTERFACE 
    114  
    115    INTERFACE mpp_max_multiple 
    116       MODULE PROCEDURE mppmax_real_multiple 
    117108   END INTERFACE 
    118109 
     
    735726      ! ----------------------- 
    736727      ! 
     728      DO ii = 1 , num_fields 
    737729         !First Array 
    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         ! 
     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 
    750740      ! 
    751741      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    20292019   END SUBROUTINE mppmax_real 
    20302020 
    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  
    20562021 
    20572022   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    29472912   END SUBROUTINE mpp_lbc_north_2d 
    29482913 
    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 
    31102914 
    31112915   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
Note: See TracChangeset for help on using the changeset viewer.