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 12143 for NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbclnk.F90 – NEMO

Ignore:
Timestamp:
2019-12-10T12:57:49+01:00 (4 years ago)
Author:
mathiot
Message:

update ENHANCE-02_ISF_nemo to 12072 (sette in progress)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbclnk.F90

    r10425 r12143  
    1414   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    1515   !!---------------------------------------------------------------------- 
    16 #if defined key_mpp_mpi 
    17    !!---------------------------------------------------------------------- 
    18    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    19    !!---------------------------------------------------------------------- 
    2016   !!           define the generic interfaces of lib_mpp routines 
    2117   !!---------------------------------------------------------------------- 
     
    2319   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2420   !!---------------------------------------------------------------------- 
    25    USE par_oce        ! ocean dynamics and tracers    
     21   USE dom_oce        ! ocean space and time domain 
    2622   USE lib_mpp        ! distributed memory computing library 
    2723   USE lbcnfd         ! north fold 
     24   USE in_out_manager ! I/O manager 
     25 
     26   IMPLICIT NONE 
     27   PRIVATE 
    2828 
    2929   INTERFACE lbc_lnk 
     
    3737   END INTERFACE 
    3838   ! 
    39    INTERFACE lbc_bdy_lnk 
    40       MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
    41    END INTERFACE 
    42    ! 
    4339   INTERFACE lbc_lnk_icb 
    4440      MODULE PROCEDURE mpp_lnk_2d_icb 
    4541   END INTERFACE 
    4642 
     43   INTERFACE mpp_nfd 
     44      MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     45      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     46   END INTERFACE 
     47 
    4748   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    4849   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    49    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    5050   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     51 
     52#if   defined key_mpp_mpi 
     53!$AGRIF_DO_NOT_TREAT 
     54   INCLUDE 'mpif.h' 
     55!$AGRIF_END_DO_NOT_TREAT 
     56#endif 
     57 
     58   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
     59   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
     60   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
     61   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
     62   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
    5163 
    5264   !!---------------------------------------------------------------------- 
     
    5668   !!---------------------------------------------------------------------- 
    5769CONTAINS 
    58  
    59 #else 
    60    !!---------------------------------------------------------------------- 
    61    !!   Default option                              shared memory computing 
    62    !!---------------------------------------------------------------------- 
    63    !!                routines setting the appropriate values 
    64    !!         on first and last row and column of the global domain 
    65    !!---------------------------------------------------------------------- 
    66    !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    67    !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
    68    !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d 
    69    !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh 
    70    !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh 
    71    !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    72    !!---------------------------------------------------------------------- 
    73    USE oce            ! ocean dynamics and tracers    
    74    USE dom_oce        ! ocean space and time domain  
    75    USE in_out_manager ! I/O manager 
    76    USE lbcnfd         ! north fold 
    77  
    78    IMPLICIT NONE 
    79    PRIVATE 
    80  
    81    INTERFACE lbc_lnk 
    82       MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d 
    83    END INTERFACE 
    84    INTERFACE lbc_lnk_ptr 
    85       MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr 
    86    END INTERFACE 
    87    INTERFACE lbc_lnk_multi 
    88       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    89    END INTERFACE 
    90    ! 
    91    INTERFACE lbc_bdy_lnk 
    92       MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d 
    93    END INTERFACE 
    94    ! 
    95    INTERFACE lbc_lnk_icb 
    96       MODULE PROCEDURE lbc_lnk_2d_icb 
    97    END INTERFACE 
    98     
    99    PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    100    PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    101    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    102    PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
    103     
    104    !!---------------------------------------------------------------------- 
    105    !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    106    !! $Id$ 
    107    !! Software governed by the CeCILL license (see ./LICENSE) 
    108    !!---------------------------------------------------------------------- 
    109 CONTAINS 
    110  
    111    !!====================================================================== 
    112    !!   Default option                           3D shared memory computing 
    113    !!====================================================================== 
    114    !!          routines setting land point, or east-west cyclic, 
    115    !!             or north-south cyclic, or north fold values 
    116    !!         on first and last row and column of the global domain 
    117    !!---------------------------------------------------------------------- 
    118  
    119    !!---------------------------------------------------------------------- 
    120    !!                   ***  routine lbc_lnk_(2,3,4)d  *** 
    121    !! 
    122    !!   * Argument : dummy argument use in lbc_lnk_... routines 
    123    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    124    !!                cd_nat :   nature of array grid-points 
    125    !!                psgn   :   sign used across the north fold boundary 
    126    !!                kfld   :   optional, number of pt3d arrays 
    127    !!                cd_mpp :   optional, fill the overlap area only 
    128    !!                pval   :   optional, background value (used at closed boundaries) 
    129    !!---------------------------------------------------------------------- 
    130    ! 
    131    !                       !==  2D array and array of 2D pointer  ==! 
    132    ! 
    133 #  define DIM_2d 
    134 #     define ROUTINE_LNK           lbc_lnk_2d 
    135 #     include "lbc_lnk_generic.h90" 
    136 #     undef ROUTINE_LNK 
    137 #     define MULTI 
    138 #     define ROUTINE_LNK           lbc_lnk_2d_ptr 
    139 #     include "lbc_lnk_generic.h90" 
    140 #     undef ROUTINE_LNK 
    141 #     undef MULTI 
    142 #  undef DIM_2d 
    143    ! 
    144    !                       !==  3D array and array of 3D pointer  ==! 
    145    ! 
    146 #  define DIM_3d 
    147 #     define ROUTINE_LNK           lbc_lnk_3d 
    148 #     include "lbc_lnk_generic.h90" 
    149 #     undef ROUTINE_LNK 
    150 #     define MULTI 
    151 #     define ROUTINE_LNK           lbc_lnk_3d_ptr 
    152 #     include "lbc_lnk_generic.h90" 
    153 #     undef ROUTINE_LNK 
    154 #     undef MULTI 
    155 #  undef DIM_3d 
    156    ! 
    157    !                       !==  4D array and array of 4D pointer  ==! 
    158    ! 
    159 #  define DIM_4d 
    160 #     define ROUTINE_LNK           lbc_lnk_4d 
    161 #     include "lbc_lnk_generic.h90" 
    162 #     undef ROUTINE_LNK 
    163 #     define MULTI 
    164 #     define ROUTINE_LNK           lbc_lnk_4d_ptr 
    165 #     include "lbc_lnk_generic.h90" 
    166 #     undef ROUTINE_LNK 
    167 #     undef MULTI 
    168 #  undef DIM_4d 
    169     
    170    !!====================================================================== 
    171    !!   identical routines in both C1D and shared memory computing 
    172    !!====================================================================== 
    173  
    174    !!---------------------------------------------------------------------- 
    175    !!                   ***  routine lbc_bdy_lnk_(2,3,4)d  *** 
    176    !! 
    177    !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    178    !!   to maintain the same interface with regards to the mpp case 
    179    !!---------------------------------------------------------------------- 
    180     
    181    SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy ) 
    182       !!---------------------------------------------------------------------- 
    183       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    184       REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt4d      ! 3D array on which the lbc is applied 
    185       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    186       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    187       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    188       !!---------------------------------------------------------------------- 
    189       CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn) 
    190    END SUBROUTINE lbc_bdy_lnk_4d 
    191  
    192    SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy ) 
    193       !!---------------------------------------------------------------------- 
    194       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    195       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    196       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    197       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    198       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    199       !!---------------------------------------------------------------------- 
    200       CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn) 
    201    END SUBROUTINE lbc_bdy_lnk_3d 
    202  
    203  
    204    SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy ) 
    205       !!---------------------------------------------------------------------- 
    206       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    207       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    208       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    209       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
    210       INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    211       !!---------------------------------------------------------------------- 
    212       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn) 
    213    END SUBROUTINE lbc_bdy_lnk_2d 
    214  
    215  
    216 !!gm  This routine should be removed with an optional halos size added in argument of generic routines 
    217  
    218    SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj ) 
    219       !!---------------------------------------------------------------------- 
    220       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    221       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    222       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    223       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
    224       INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    225       !!---------------------------------------------------------------------- 
    226       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn ) 
    227    END SUBROUTINE lbc_lnk_2d_icb 
    228 !!gm end 
    229  
    230 #endif 
    231  
    232    !!====================================================================== 
    233    !!   identical routines in both distributed and shared memory computing 
    234    !!====================================================================== 
    23570 
    23671   !!---------------------------------------------------------------------- 
     
    25691 
    25792#  define DIM_2d 
     93#     define ROUTINE_LOAD           load_ptr_2d 
    25894#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    259 #     define ROUTINE_LOAD           load_ptr_2d 
    26095#     include "lbc_lnk_multi_generic.h90" 
    26196#     undef ROUTINE_MULTI 
     
    26398#  undef DIM_2d 
    26499 
    265  
    266100#  define DIM_3d 
     101#     define ROUTINE_LOAD           load_ptr_3d 
    267102#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    268 #     define ROUTINE_LOAD           load_ptr_3d 
    269103#     include "lbc_lnk_multi_generic.h90" 
    270104#     undef ROUTINE_MULTI 
     
    272106#  undef DIM_3d 
    273107 
    274  
    275108#  define DIM_4d 
     109#     define ROUTINE_LOAD           load_ptr_4d 
    276110#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
    277 #     define ROUTINE_LOAD           load_ptr_4d 
    278111#     include "lbc_lnk_multi_generic.h90" 
    279112#     undef ROUTINE_MULTI 
     
    281114#  undef DIM_4d 
    282115 
     116   !!---------------------------------------------------------------------- 
     117   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     118   !! 
     119   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     120   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     121   !!                cd_nat    :   nature of array grid-points 
     122   !!                psgn      :   sign used across the north fold boundary 
     123   !!                kfld      :   optional, number of pt3d arrays 
     124   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     125   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     126   !!---------------------------------------------------------------------- 
     127   ! 
     128   !                       !==  2D array and array of 2D pointer  ==! 
     129   ! 
     130#  define DIM_2d 
     131#     define ROUTINE_LNK           mpp_lnk_2d 
     132#     include "mpp_lnk_generic.h90" 
     133#     undef ROUTINE_LNK 
     134#     define MULTI 
     135#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     136#     include "mpp_lnk_generic.h90" 
     137#     undef ROUTINE_LNK 
     138#     undef MULTI 
     139#  undef DIM_2d 
     140   ! 
     141   !                       !==  3D array and array of 3D pointer  ==! 
     142   ! 
     143#  define DIM_3d 
     144#     define ROUTINE_LNK           mpp_lnk_3d 
     145#     include "mpp_lnk_generic.h90" 
     146#     undef ROUTINE_LNK 
     147#     define MULTI 
     148#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     149#     include "mpp_lnk_generic.h90" 
     150#     undef ROUTINE_LNK 
     151#     undef MULTI 
     152#  undef DIM_3d 
     153   ! 
     154   !                       !==  4D array and array of 4D pointer  ==! 
     155   ! 
     156#  define DIM_4d 
     157#     define ROUTINE_LNK           mpp_lnk_4d 
     158#     include "mpp_lnk_generic.h90" 
     159#     undef ROUTINE_LNK 
     160#     define MULTI 
     161#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     162#     include "mpp_lnk_generic.h90" 
     163#     undef ROUTINE_LNK 
     164#     undef MULTI 
     165#  undef DIM_4d 
     166 
     167   !!---------------------------------------------------------------------- 
     168   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     169   !! 
     170   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     171   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     172   !!                cd_nat    :   nature of array grid-points 
     173   !!                psgn      :   sign used across the north fold boundary 
     174   !!                kfld      :   optional, number of pt3d arrays 
     175   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     176   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     177   !!---------------------------------------------------------------------- 
     178   ! 
     179   !                       !==  2D array and array of 2D pointer  ==! 
     180   ! 
     181#  define DIM_2d 
     182#     define ROUTINE_NFD           mpp_nfd_2d 
     183#     include "mpp_nfd_generic.h90" 
     184#     undef ROUTINE_NFD 
     185#     define MULTI 
     186#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     187#     include "mpp_nfd_generic.h90" 
     188#     undef ROUTINE_NFD 
     189#     undef MULTI 
     190#  undef DIM_2d 
     191   ! 
     192   !                       !==  3D array and array of 3D pointer  ==! 
     193   ! 
     194#  define DIM_3d 
     195#     define ROUTINE_NFD           mpp_nfd_3d 
     196#     include "mpp_nfd_generic.h90" 
     197#     undef ROUTINE_NFD 
     198#     define MULTI 
     199#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     200#     include "mpp_nfd_generic.h90" 
     201#     undef ROUTINE_NFD 
     202#     undef MULTI 
     203#  undef DIM_3d 
     204   ! 
     205   !                       !==  4D array and array of 4D pointer  ==! 
     206   ! 
     207#  define DIM_4d 
     208#     define ROUTINE_NFD           mpp_nfd_4d 
     209#     include "mpp_nfd_generic.h90" 
     210#     undef ROUTINE_NFD 
     211#     define MULTI 
     212#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     213#     include "mpp_nfd_generic.h90" 
     214#     undef ROUTINE_NFD 
     215#     undef MULTI 
     216#  undef DIM_4d 
     217 
     218 
    283219   !!====================================================================== 
     220 
     221 
     222 
     223   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
     224      !!--------------------------------------------------------------------- 
     225      !!                   ***  routine mpp_lbc_north_icb  *** 
     226      !! 
     227      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     228      !!              in mpp configuration in case of jpn1 > 1 and for 2d 
     229      !!              array with outer extra halo 
     230      !! 
     231      !! ** Method  :   North fold condition and mpp with more than one proc 
     232      !!              in i-direction require a specific treatment. We gather 
     233      !!              the 4+kextj northern lines of the global domain on 1 
     234      !!              processor and apply lbc north-fold on this sub array. 
     235      !!              Then we scatter the north fold array back to the processors. 
     236      !!              This routine accounts for an extra halo with icebergs 
     237      !!              and assumes ghost rows and columns have been suppressed. 
     238      !! 
     239      !!---------------------------------------------------------------------- 
     240      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     241      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
     242      !                                                     !   = T ,  U , V , F or W -points 
     243      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
     244      !!                                                    ! north fold, =  1. otherwise 
     245      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
     246      ! 
     247      INTEGER ::   ji, jj, jr 
     248      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     249      INTEGER ::   ipj, ij, iproc 
     250      ! 
     251      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
     252      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
     253      !!---------------------------------------------------------------------- 
     254#if defined key_mpp_mpi 
     255      ! 
     256      ipj=4 
     257      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
     258     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
     259     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
     260      ! 
     261      ztab_e(:,:)      = 0._wp 
     262      znorthloc_e(:,:) = 0._wp 
     263      ! 
     264      ij = 1 - kextj 
     265      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
     266      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     267         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
     268         ij = ij + 1 
     269      END DO 
     270      ! 
     271      itaille = jpimax * ( ipj + 2*kextj ) 
     272      ! 
     273      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     274      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
     275         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
     276         &                ncomm_north, ierr ) 
     277      ! 
     278      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     279      ! 
     280      DO jr = 1, ndim_rank_north            ! recover the global north array 
     281         iproc = nrank_north(jr) + 1 
     282         ildi = nldit (iproc) 
     283         ilei = nleit (iproc) 
     284         iilb = nimppt(iproc) 
     285         DO jj = 1-kextj, ipj+kextj 
     286            DO ji = ildi, ilei 
     287               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
     288            END DO 
     289         END DO 
     290      END DO 
     291 
     292      ! 2. North-Fold boundary conditions 
     293      ! ---------------------------------- 
     294      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
     295 
     296      ij = 1 - kextj 
     297      !! Scatter back to pt2d 
     298      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     299         DO ji= 1, jpi 
     300            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
     301         END DO 
     302         ij  = ij +1 
     303      END DO 
     304      ! 
     305      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
     306      ! 
     307#endif 
     308   END SUBROUTINE mpp_lbc_north_icb 
     309 
     310 
     311   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     312      !!---------------------------------------------------------------------- 
     313      !!                  ***  routine mpp_lnk_2d_icb  *** 
     314      !! 
     315      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     316      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
     317      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
     318      !! 
     319      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     320      !!      between processors following neighboring subdomains. 
     321      !!            domain parameters 
     322      !!                    jpi    : first dimension of the local subdomain 
     323      !!                    jpj    : second dimension of the local subdomain 
     324      !!                    kexti  : number of columns for extra outer halo 
     325      !!                    kextj  : number of rows for extra outer halo 
     326      !!                    nbondi : mark for "east-west local boundary" 
     327      !!                    nbondj : mark for "north-south local boundary" 
     328      !!                    noea   : number for local neighboring processors 
     329      !!                    nowe   : number for local neighboring processors 
     330      !!                    noso   : number for local neighboring processors 
     331      !!                    nono   : number for local neighboring processors 
     332      !!---------------------------------------------------------------------- 
     333      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     334      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     335      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     336      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     337      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
     338      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
     339      ! 
     340      INTEGER  ::   jl   ! dummy loop indices 
     341      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     342      INTEGER  ::   ipreci, iprecj             !   -       - 
     343      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     344      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     345      !! 
     346      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
     347      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
     348      !!---------------------------------------------------------------------- 
     349 
     350      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
     351      iprecj = nn_hls + kextj 
     352 
     353      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
     354 
     355      ! 1. standard boundary treatment 
     356      ! ------------------------------ 
     357      ! Order matters Here !!!! 
     358      ! 
     359      !                                      ! East-West boundaries 
     360      !                                           !* Cyclic east-west 
     361      IF( l_Iperio ) THEN 
     362         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
     363         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
     364         ! 
     365      ELSE                                        !* closed 
     366         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
     367                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
     368      ENDIF 
     369      !                                      ! North-South boundaries 
     370      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
     371         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
     372         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
     373      ELSE                                        !* closed 
     374         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
     375                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
     376      ENDIF 
     377      ! 
     378 
     379      ! north fold treatment 
     380      ! ----------------------- 
     381      IF( npolj /= 0 ) THEN 
     382         ! 
     383         SELECT CASE ( jpni ) 
     384                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     385                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     386         END SELECT 
     387         ! 
     388      ENDIF 
     389 
     390      ! 2. East and west directions exchange 
     391      ! ------------------------------------ 
     392      ! we play with the neigbours AND the row number because of the periodicity 
     393      ! 
     394      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     395      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     396         iihom = jpi-nreci-kexti 
     397         DO jl = 1, ipreci 
     398            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
     399            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
     400         END DO 
     401      END SELECT 
     402      ! 
     403      !                           ! Migrations 
     404      imigr = ipreci * ( jpj + 2*kextj ) 
     405      ! 
     406      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     407      ! 
     408      SELECT CASE ( nbondi ) 
     409      CASE ( -1 ) 
     410         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
     411         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     412         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     413      CASE ( 0 ) 
     414         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     415         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
     416         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     417         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     418         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     419         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     420      CASE ( 1 ) 
     421         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     422         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     423         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     424      END SELECT 
     425      ! 
     426      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     427      ! 
     428      !                           ! Write Dirichlet lateral conditions 
     429      iihom = jpi - nn_hls 
     430      ! 
     431      SELECT CASE ( nbondi ) 
     432      CASE ( -1 ) 
     433         DO jl = 1, ipreci 
     434            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     435         END DO 
     436      CASE ( 0 ) 
     437         DO jl = 1, ipreci 
     438            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     439            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     440         END DO 
     441      CASE ( 1 ) 
     442         DO jl = 1, ipreci 
     443            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     444         END DO 
     445      END SELECT 
     446 
     447 
     448      ! 3. North and south directions 
     449      ! ----------------------------- 
     450      ! always closed : we play only with the neigbours 
     451      ! 
     452      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     453         ijhom = jpj-nrecj-kextj 
     454         DO jl = 1, iprecj 
     455            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
     456            r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
     457         END DO 
     458      ENDIF 
     459      ! 
     460      !                           ! Migrations 
     461      imigr = iprecj * ( jpi + 2*kexti ) 
     462      ! 
     463      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     464      ! 
     465      SELECT CASE ( nbondj ) 
     466      CASE ( -1 ) 
     467         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
     468         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     469         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     470      CASE ( 0 ) 
     471         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     472         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
     473         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     474         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     475         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     476         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     477      CASE ( 1 ) 
     478         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     479         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     480         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     481      END SELECT 
     482      ! 
     483      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     484      ! 
     485      !                           ! Write Dirichlet lateral conditions 
     486      ijhom = jpj - nn_hls 
     487      ! 
     488      SELECT CASE ( nbondj ) 
     489      CASE ( -1 ) 
     490         DO jl = 1, iprecj 
     491            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     492         END DO 
     493      CASE ( 0 ) 
     494         DO jl = 1, iprecj 
     495            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     496            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     497         END DO 
     498      CASE ( 1 ) 
     499         DO jl = 1, iprecj 
     500            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     501         END DO 
     502      END SELECT 
     503      ! 
     504   END SUBROUTINE mpp_lnk_2d_icb 
     505    
    284506END MODULE lbclnk 
    285507 
Note: See TracChangeset for help on using the changeset viewer.