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 13247 for NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbclnk.F90 – NEMO

Ignore:
Timestamp:
2020-07-03T19:15:31+02:00 (4 years ago)
Author:
francesca
Message:

dev_r12558_HPC-08_epico_Extra_Halo: merge with trunk@13227, see #2366

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbclnk.F90

    r12807 r13247  
    2828 
    2929   INTERFACE lbc_lnk 
    30       MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     30      MODULE PROCEDURE   mpp_lnk_2d_sp   , mpp_lnk_3d_sp   , mpp_lnk_4d_sp 
     31      MODULE PROCEDURE   mpp_lnk_2d_dp   , mpp_lnk_3d_dp   , mpp_lnk_4d_dp 
    3132   END INTERFACE 
    3233   INTERFACE lbc_lnk_ptr 
    33       MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr 
     34      MODULE PROCEDURE   mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 
     35      MODULE PROCEDURE   mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 
    3436   END INTERFACE 
    3537   INTERFACE lbc_lnk_multi 
    36       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
     38      MODULE PROCEDURE   lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 
     39      MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    3740   END INTERFACE 
    3841   ! 
    3942   INTERFACE lbc_lnk_icb 
    40       MODULE PROCEDURE mpp_lnk_2d_icb 
     43      MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 
    4144   END INTERFACE 
    4245 
    4346   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 
     47      MODULE PROCEDURE   mpp_nfd_2d_sp    , mpp_nfd_3d_sp    , mpp_nfd_4d_sp 
     48      MODULE PROCEDURE   mpp_nfd_2d_dp    , mpp_nfd_3d_dp    , mpp_nfd_4d_dp 
     49      MODULE PROCEDURE   mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 
     50      MODULE PROCEDURE   mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 
     51       
    4652   END INTERFACE 
    4753 
     
    9298   !!---------------------------------------------------------------------- 
    9399 
    94 #  define DIM_2d 
    95 #     define ROUTINE_LOAD           load_ptr_2d 
    96 #     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    97 #     include "lbc_lnk_multi_generic.h90" 
    98 #     undef ROUTINE_MULTI 
    99 #     undef ROUTINE_LOAD 
    100 #  undef DIM_2d 
    101  
    102 #  define DIM_3d 
    103 #     define ROUTINE_LOAD           load_ptr_3d 
    104 #     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    105 #     include "lbc_lnk_multi_generic.h90" 
    106 #     undef ROUTINE_MULTI 
    107 #     undef ROUTINE_LOAD 
    108 #  undef DIM_3d 
    109  
    110 #  define DIM_4d 
    111 #     define ROUTINE_LOAD           load_ptr_4d 
    112 #     define ROUTINE_MULTI          lbc_lnk_4d_multi 
     100   !! 
     101   !!   ----   SINGLE PRECISION VERSIONS 
     102   !! 
     103#  define SINGLE_PRECISION 
     104#  define DIM_2d 
     105#     define ROUTINE_LOAD           load_ptr_2d_sp 
     106#     define ROUTINE_MULTI          lbc_lnk_2d_multi_sp 
     107#     include "lbc_lnk_multi_generic.h90" 
     108#     undef ROUTINE_MULTI 
     109#     undef ROUTINE_LOAD 
     110#  undef DIM_2d 
     111 
     112#  define DIM_3d 
     113#     define ROUTINE_LOAD           load_ptr_3d_sp 
     114#     define ROUTINE_MULTI          lbc_lnk_3d_multi_sp 
     115#     include "lbc_lnk_multi_generic.h90" 
     116#     undef ROUTINE_MULTI 
     117#     undef ROUTINE_LOAD 
     118#  undef DIM_3d 
     119 
     120#  define DIM_4d 
     121#     define ROUTINE_LOAD           load_ptr_4d_sp 
     122#     define ROUTINE_MULTI          lbc_lnk_4d_multi_sp 
     123#     include "lbc_lnk_multi_generic.h90" 
     124#     undef ROUTINE_MULTI 
     125#     undef ROUTINE_LOAD 
     126#  undef DIM_4d 
     127#  undef SINGLE_PRECISION 
     128   !! 
     129   !!   ----   DOUBLE PRECISION VERSIONS 
     130   !! 
     131 
     132#  define DIM_2d 
     133#     define ROUTINE_LOAD           load_ptr_2d_dp 
     134#     define ROUTINE_MULTI          lbc_lnk_2d_multi_dp 
     135#     include "lbc_lnk_multi_generic.h90" 
     136#     undef ROUTINE_MULTI 
     137#     undef ROUTINE_LOAD 
     138#  undef DIM_2d 
     139 
     140#  define DIM_3d 
     141#     define ROUTINE_LOAD           load_ptr_3d_dp 
     142#     define ROUTINE_MULTI          lbc_lnk_3d_multi_dp 
     143#     include "lbc_lnk_multi_generic.h90" 
     144#     undef ROUTINE_MULTI 
     145#     undef ROUTINE_LOAD 
     146#  undef DIM_3d 
     147 
     148#  define DIM_4d 
     149#     define ROUTINE_LOAD           load_ptr_4d_dp 
     150#     define ROUTINE_MULTI          lbc_lnk_4d_multi_dp 
    113151#     include "lbc_lnk_multi_generic.h90" 
    114152#     undef ROUTINE_MULTI 
     
    130168   !                       !==  2D array and array of 2D pointer  ==! 
    131169   ! 
    132 #  define DIM_2d 
    133 #     define ROUTINE_LNK           mpp_lnk_2d 
    134 #     include "mpp_lnk_generic.h90" 
    135 #     undef ROUTINE_LNK 
    136 #     define MULTI 
    137 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     170   !! 
     171   !!   ----   SINGLE PRECISION VERSIONS 
     172   !! 
     173# define SINGLE_PRECISION 
     174#  define DIM_2d 
     175#     define ROUTINE_LNK           mpp_lnk_2d_sp 
     176#     include "mpp_lnk_generic.h90" 
     177#     undef ROUTINE_LNK 
     178#     define MULTI 
     179#     define ROUTINE_LNK           mpp_lnk_2d_ptr_sp 
    138180#     include "mpp_lnk_generic.h90" 
    139181#     undef ROUTINE_LNK 
     
    144186   ! 
    145187#  define DIM_3d 
    146 #     define ROUTINE_LNK           mpp_lnk_3d 
    147 #     include "mpp_lnk_generic.h90" 
    148 #     undef ROUTINE_LNK 
    149 #     define MULTI 
    150 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     188#     define ROUTINE_LNK           mpp_lnk_3d_sp 
     189#     include "mpp_lnk_generic.h90" 
     190#     undef ROUTINE_LNK 
     191#     define MULTI 
     192#     define ROUTINE_LNK           mpp_lnk_3d_ptr_sp 
    151193#     include "mpp_lnk_generic.h90" 
    152194#     undef ROUTINE_LNK 
     
    157199   ! 
    158200#  define DIM_4d 
    159 #     define ROUTINE_LNK           mpp_lnk_4d 
    160 #     include "mpp_lnk_generic.h90" 
    161 #     undef ROUTINE_LNK 
    162 #     define MULTI 
    163 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    164 #     include "mpp_lnk_generic.h90" 
    165 #     undef ROUTINE_LNK 
    166 #     undef MULTI 
    167 #  undef DIM_4d 
     201#     define ROUTINE_LNK           mpp_lnk_4d_sp 
     202#     include "mpp_lnk_generic.h90" 
     203#     undef ROUTINE_LNK 
     204#     define MULTI 
     205#     define ROUTINE_LNK           mpp_lnk_4d_ptr_sp 
     206#     include "mpp_lnk_generic.h90" 
     207#     undef ROUTINE_LNK 
     208#     undef MULTI 
     209#  undef DIM_4d 
     210# undef SINGLE_PRECISION 
     211 
     212   !! 
     213   !!   ----   DOUBLE PRECISION VERSIONS 
     214   !! 
     215#  define DIM_2d 
     216#     define ROUTINE_LNK           mpp_lnk_2d_dp 
     217#     include "mpp_lnk_generic.h90" 
     218#     undef ROUTINE_LNK 
     219#     define MULTI 
     220#     define ROUTINE_LNK           mpp_lnk_2d_ptr_dp 
     221#     include "mpp_lnk_generic.h90" 
     222#     undef ROUTINE_LNK 
     223#     undef MULTI 
     224#  undef DIM_2d 
     225   ! 
     226   !                       !==  3D array and array of 3D pointer  ==! 
     227   ! 
     228#  define DIM_3d 
     229#     define ROUTINE_LNK           mpp_lnk_3d_dp 
     230#     include "mpp_lnk_generic.h90" 
     231#     undef ROUTINE_LNK 
     232#     define MULTI 
     233#     define ROUTINE_LNK           mpp_lnk_3d_ptr_dp 
     234#     include "mpp_lnk_generic.h90" 
     235#     undef ROUTINE_LNK 
     236#     undef MULTI 
     237#  undef DIM_3d 
     238   ! 
     239   !                       !==  4D array and array of 4D pointer  ==! 
     240   ! 
     241#  define DIM_4d 
     242#     define ROUTINE_LNK           mpp_lnk_4d_dp 
     243#     include "mpp_lnk_generic.h90" 
     244#     undef ROUTINE_LNK 
     245#     define MULTI 
     246#     define ROUTINE_LNK           mpp_lnk_4d_ptr_dp 
     247#     include "mpp_lnk_generic.h90" 
     248#     undef ROUTINE_LNK 
     249#     undef MULTI 
     250#  undef DIM_4d 
     251 
    168252 
    169253   !!---------------------------------------------------------------------- 
     
    181265   !                       !==  2D array and array of 2D pointer  ==! 
    182266   ! 
    183 #  define DIM_2d 
    184 #     define ROUTINE_NFD           mpp_nfd_2d 
    185 #     include "mpp_nfd_generic.h90" 
    186 #     undef ROUTINE_NFD 
    187 #     define MULTI 
    188 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     267   !! 
     268   !!   ----   SINGLE PRECISION VERSIONS 
     269   !! 
     270#  define SINGLE_PRECISION 
     271#  define DIM_2d 
     272#     define ROUTINE_NFD           mpp_nfd_2d_sp 
     273#     include "mpp_nfd_generic.h90" 
     274#     undef ROUTINE_NFD 
     275#     define MULTI 
     276#     define ROUTINE_NFD           mpp_nfd_2d_ptr_sp 
    189277#     include "mpp_nfd_generic.h90" 
    190278#     undef ROUTINE_NFD 
     
    195283   ! 
    196284#  define DIM_3d 
    197 #     define ROUTINE_NFD           mpp_nfd_3d 
    198 #     include "mpp_nfd_generic.h90" 
    199 #     undef ROUTINE_NFD 
    200 #     define MULTI 
    201 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     285#     define ROUTINE_NFD           mpp_nfd_3d_sp 
     286#     include "mpp_nfd_generic.h90" 
     287#     undef ROUTINE_NFD 
     288#     define MULTI 
     289#     define ROUTINE_NFD           mpp_nfd_3d_ptr_sp 
    202290#     include "mpp_nfd_generic.h90" 
    203291#     undef ROUTINE_NFD 
     
    208296   ! 
    209297#  define DIM_4d 
    210 #     define ROUTINE_NFD           mpp_nfd_4d 
    211 #     include "mpp_nfd_generic.h90" 
    212 #     undef ROUTINE_NFD 
    213 #     define MULTI 
    214 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    215 #     include "mpp_nfd_generic.h90" 
    216 #     undef ROUTINE_NFD 
    217 #     undef MULTI 
    218 #  undef DIM_4d 
    219  
     298#     define ROUTINE_NFD           mpp_nfd_4d_sp 
     299#     include "mpp_nfd_generic.h90" 
     300#     undef ROUTINE_NFD 
     301#     define MULTI 
     302#     define ROUTINE_NFD           mpp_nfd_4d_ptr_sp 
     303#     include "mpp_nfd_generic.h90" 
     304#     undef ROUTINE_NFD 
     305#     undef MULTI 
     306#  undef DIM_4d 
     307#  undef SINGLE_PRECISION 
     308 
     309   !! 
     310   !!   ----   DOUBLE PRECISION VERSIONS 
     311   !! 
     312#  define DIM_2d 
     313#     define ROUTINE_NFD           mpp_nfd_2d_dp 
     314#     include "mpp_nfd_generic.h90" 
     315#     undef ROUTINE_NFD 
     316#     define MULTI 
     317#     define ROUTINE_NFD           mpp_nfd_2d_ptr_dp 
     318#     include "mpp_nfd_generic.h90" 
     319#     undef ROUTINE_NFD 
     320#     undef MULTI 
     321#  undef DIM_2d 
     322   ! 
     323   !                       !==  3D array and array of 3D pointer  ==! 
     324   ! 
     325#  define DIM_3d 
     326#     define ROUTINE_NFD           mpp_nfd_3d_dp 
     327#     include "mpp_nfd_generic.h90" 
     328#     undef ROUTINE_NFD 
     329#     define MULTI 
     330#     define ROUTINE_NFD           mpp_nfd_3d_ptr_dp 
     331#     include "mpp_nfd_generic.h90" 
     332#     undef ROUTINE_NFD 
     333#     undef MULTI 
     334#  undef DIM_3d 
     335   ! 
     336   !                       !==  4D array and array of 4D pointer  ==! 
     337   ! 
     338#  define DIM_4d 
     339#     define ROUTINE_NFD           mpp_nfd_4d_dp 
     340#     include "mpp_nfd_generic.h90" 
     341#     undef ROUTINE_NFD 
     342#     define MULTI 
     343#     define ROUTINE_NFD           mpp_nfd_4d_ptr_dp 
     344#     include "mpp_nfd_generic.h90" 
     345#     undef ROUTINE_NFD 
     346#     undef MULTI 
     347#  undef DIM_4d 
    220348 
    221349   !!====================================================================== 
    222350 
    223351 
    224  
    225    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    226       !!--------------------------------------------------------------------- 
     352   !!====================================================================== 
     353     !!--------------------------------------------------------------------- 
    227354      !!                   ***  routine mpp_lbc_north_icb  *** 
    228355      !! 
     
    240367      !! 
    241368      !!---------------------------------------------------------------------- 
    242       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    243       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    244       !                                                     !   = T ,  U , V , F or W -points 
    245       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    246       !!                                                    ! north fold, =  1. otherwise 
    247       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    248       ! 
    249       INTEGER ::   ji, jj, jr 
    250       INTEGER ::   ierr, itaille, iis0, iie0, iilb 
    251       INTEGER ::   ipj, ij, iproc 
    252       ! 
    253       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    254       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    255       !!---------------------------------------------------------------------- 
    256 #if defined key_mpp_mpi 
    257       ! 
    258       ipj=4 
    259       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    260      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    261      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    262       ! 
    263       ztab_e(:,:)      = 0._wp 
    264       znorthloc_e(:,:) = 0._wp 
    265       ! 
    266       ij = 1 - kextj 
    267       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    268       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    269          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    270          ij = ij + 1 
    271       END DO 
    272       ! 
    273       itaille = jpimax * ( ipj + 2*kextj ) 
    274       ! 
    275       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    276       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    277          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    278          &                ncomm_north, ierr ) 
    279       ! 
    280       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    281       ! 
    282       DO jr = 1, ndim_rank_north            ! recover the global north array 
    283          iproc = nrank_north(jr) + 1 
    284          iis0 = nis0all(iproc) 
    285          iie0 = nie0all(iproc) 
    286          iilb = nimppt(iproc) 
    287          DO jj = 1-kextj, ipj+kextj 
    288             DO ji = iis0, iie0 
    289                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    290             END DO 
    291          END DO 
    292       END DO 
    293  
    294       ! 2. North-Fold boundary conditions 
    295       ! ---------------------------------- 
    296       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    297  
    298       ij = 1 - kextj 
    299       !! Scatter back to pt2d 
    300       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    301          DO ji= 1, jpi 
    302             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    303          END DO 
    304          ij  = ij +1 
    305       END DO 
    306       ! 
    307       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    308       ! 
    309 #endif 
    310    END SUBROUTINE mpp_lbc_north_icb 
    311  
    312  
    313    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     369#     define SINGLE_PRECISION 
     370#     define ROUTINE_LNK           mpp_lbc_north_icb_sp 
     371#     include "mpp_lbc_north_icb_generic.h90" 
     372#     undef ROUTINE_LNK 
     373#     undef SINGLE_PRECISION 
     374#     define ROUTINE_LNK           mpp_lbc_north_icb_dp 
     375#     include "mpp_lbc_north_icb_generic.h90" 
     376#     undef ROUTINE_LNK 
     377  
     378 
    314379      !!---------------------------------------------------------------------- 
    315380      !!                  ***  routine mpp_lnk_2d_icb  *** 
     
    333398      !!                    nono   : number for local neighboring processors 
    334399      !!---------------------------------------------------------------------- 
    335       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    336       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    337       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    338       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    339       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    340       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    341       ! 
    342       INTEGER  ::   jl   ! dummy loop indices 
    343       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    344       INTEGER  ::   ipreci, iprecj             !   -       - 
    345       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    346       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    347       !! 
    348       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    349       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    350       !!---------------------------------------------------------------------- 
    351  
    352       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    353       iprecj = nn_hls + kextj 
    354  
    355       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    356  
    357       ! 1. standard boundary treatment 
    358       ! ------------------------------ 
    359       ! Order matters Here !!!! 
    360       ! 
    361       !                                      ! East-West boundaries 
    362       !                                           !* Cyclic east-west 
    363       IF( l_Iperio ) THEN 
    364          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    365          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    366          ! 
    367       ELSE                                        !* closed 
    368          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    369                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    370       ENDIF 
    371       !                                      ! North-South boundaries 
    372       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    373          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    374          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    375       ELSE                                        !* closed 
    376          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    377                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    378       ENDIF 
    379       ! 
    380  
    381       ! north fold treatment 
    382       ! ----------------------- 
    383       IF( npolj /= 0 ) THEN 
    384          ! 
    385          SELECT CASE ( jpni ) 
    386                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    387                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    388          END SELECT 
    389          ! 
    390       ENDIF 
    391  
    392       ! 2. East and west directions exchange 
    393       ! ------------------------------------ 
    394       ! we play with the neigbours AND the row number because of the periodicity 
    395       ! 
    396       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    397       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    398          iihom = jpi - (2 * nn_hls) - kexti 
    399          DO jl = 1, ipreci 
    400             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    401             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    402          END DO 
    403       END SELECT 
    404       ! 
    405       !                           ! Migrations 
    406       imigr = ipreci * ( jpj + 2*kextj ) 
    407       ! 
    408       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    409       ! 
    410       SELECT CASE ( nbondi ) 
    411       CASE ( -1 ) 
    412          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    413          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    414          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    415       CASE ( 0 ) 
    416          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    417          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    418          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    419          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    420          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    421          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    422       CASE ( 1 ) 
    423          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    424          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    425          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    426       END SELECT 
    427       ! 
    428       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    429       ! 
    430       !                           ! Write Dirichlet lateral conditions 
    431       iihom = jpi - nn_hls 
    432       ! 
    433       SELECT CASE ( nbondi ) 
    434       CASE ( -1 ) 
    435          DO jl = 1, ipreci 
    436             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    437          END DO 
    438       CASE ( 0 ) 
    439          DO jl = 1, ipreci 
    440             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    441             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    442          END DO 
    443       CASE ( 1 ) 
    444          DO jl = 1, ipreci 
    445             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    446          END DO 
    447       END SELECT 
    448  
    449  
    450       ! 3. North and south directions 
    451       ! ----------------------------- 
    452       ! always closed : we play only with the neigbours 
    453       ! 
    454       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    455          ijhom = jpj - ( 2 * nn_hls ) -kextj 
    456          DO jl = 1, iprecj 
    457             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    458             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    459          END DO 
    460       ENDIF 
    461       ! 
    462       !                           ! Migrations 
    463       imigr = iprecj * ( jpi + 2*kexti ) 
    464       ! 
    465       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    466       ! 
    467       SELECT CASE ( nbondj ) 
    468       CASE ( -1 ) 
    469          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    470          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    471          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    472       CASE ( 0 ) 
    473          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    474          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    475          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    476          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    477          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    478          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    479       CASE ( 1 ) 
    480          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    481          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    482          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    483       END SELECT 
    484       ! 
    485       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    486       ! 
    487       !                           ! Write Dirichlet lateral conditions 
    488       ijhom = jpj - nn_hls 
    489       ! 
    490       SELECT CASE ( nbondj ) 
    491       CASE ( -1 ) 
    492          DO jl = 1, iprecj 
    493             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    494          END DO 
    495       CASE ( 0 ) 
    496          DO jl = 1, iprecj 
    497             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    498             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    499          END DO 
    500       CASE ( 1 ) 
    501          DO jl = 1, iprecj 
    502             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    503          END DO 
    504       END SELECT 
    505       ! 
    506    END SUBROUTINE mpp_lnk_2d_icb 
    507     
     400 
     401#     define SINGLE_PRECISION 
     402#     define ROUTINE_LNK           mpp_lnk_2d_icb_sp 
     403#     include "mpp_lnk_icb_generic.h90" 
     404#     undef ROUTINE_LNK 
     405#     undef SINGLE_PRECISION 
     406#     define ROUTINE_LNK           mpp_lnk_2d_icb_dp 
     407#     include "mpp_lnk_icb_generic.h90" 
     408#     undef ROUTINE_LNK 
     409   
    508410END MODULE lbclnk 
    509411 
Note: See TracChangeset for help on using the changeset viewer.