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 9019 for branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 – NEMO

Ignore:
Timestamp:
2017-12-13T15:58:53+01:00 (6 years ago)
Author:
timgraham
Message:

Merge of dev_CNRS_2017 into branch

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r7646 r9019  
    55   !!====================================================================== 
    66   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code  
    7    !!            3.5  ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization  
     7   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization 
     8   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
    89   !!---------------------------------------------------------------------- 
    910 
     
    1213   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1314   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    14    !!   mpp_lbc_nfd_3d    : North fold treatment for a 3D arrays optimized for MPP 
    15    !!   mpp_lbc_nfd_2d    : North fold treatment for a 2D arrays optimized for MPP 
     15   !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and  
     16   !!                            lbc_nfd_nogather_2d routines (designed for use 
     17   !!                            with ln_nnogather to avoid global width arrays 
     18   !!                            mpi all gather operations) 
    1619   !!---------------------------------------------------------------------- 
    1720   USE dom_oce        ! ocean space and time domain  
     
    2225 
    2326   INTERFACE lbc_nfd 
    24       MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d 
     27      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
     28      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
     29      MODULE PROCEDURE   lbc_nfd_2d_ext 
    2530   END INTERFACE 
    2631   ! 
    27    INTERFACE mpp_lbc_nfd 
    28       MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 
     32   INTERFACE lbc_nfd_nogather 
     33!                        ! Currently only 4d array version is needed 
     34!     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
     35      MODULE PROCEDURE   lbc_nfd_nogather_4d 
     36!     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     37!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    2938   END INTERFACE 
    3039 
    31    PUBLIC   lbc_nfd       ! north fold conditions 
    32    PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case) 
     40   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
     41      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
     42   END TYPE PTR_2D 
     43   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
     44      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     45   END TYPE PTR_3D 
     46   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
     47      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     48   END TYPE PTR_4D 
     49 
     50   PUBLIC   lbc_nfd            ! north fold conditions 
     51   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case) 
    3352 
    3453   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
     
    4362CONTAINS 
    4463 
    45    SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 
    46       !!---------------------------------------------------------------------- 
    47       !!                  ***  routine lbc_nfd_3d  *** 
    48       !! 
    49       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    50       !!              without processor exchanges.  
    51       !! 
    52       !! ** Method  :    
    53       !! 
    54       !! ** Action  :   pt3d with updated values along the north fold 
    55       !!---------------------------------------------------------------------- 
    56       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    57       !                                                        !   = T , U , V , F , W points 
    58       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    59       !                                                        !   = -1. , the sign is changed if north fold boundary 
    60       !                                                        !   =  1. , the sign is kept  if north fold boundary 
    61       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
    62       ! 
    63       INTEGER  ::   ji, jk 
    64       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    65       !!---------------------------------------------------------------------- 
     64   !!---------------------------------------------------------------------- 
     65   !!                   ***  routine lbc_nfd_(2,3,4)d  *** 
     66   !!---------------------------------------------------------------------- 
     67   !! 
     68   !! ** Purpose :   lateral boundary condition  
     69   !!                North fold treatment without processor exchanges.  
     70   !! 
     71   !! ** Method  :    
     72   !! 
     73   !! ** Action  :   ptab with updated values along the north fold 
     74   !!---------------------------------------------------------------------- 
     75   ! 
     76   !                       !==  2D array and array of 2D pointer  ==! 
     77   ! 
     78#  define DIM_2d 
     79#     define ROUTINE_NFD           lbc_nfd_2d 
     80#     include "lbc_nfd_generic.h90" 
     81#     undef ROUTINE_NFD 
     82#     define MULTI 
     83#     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     84#     include "lbc_nfd_generic.h90" 
     85#     undef ROUTINE_NFD 
     86#     undef MULTI 
     87#  undef DIM_2d 
     88   ! 
     89   !                       !==  2D array with extra haloes  ==! 
     90   ! 
     91#  define DIM_2d 
     92#     define ROUTINE_NFD           lbc_nfd_2d_ext 
     93#     include "lbc_nfd_ext_generic.h90" 
     94#     undef ROUTINE_NFD 
     95#  undef DIM_2d 
     96   ! 
     97   !                       !==  3D array and array of 3D pointer  ==! 
     98   ! 
     99#  define DIM_3d 
     100#     define ROUTINE_NFD           lbc_nfd_3d 
     101#     include "lbc_nfd_generic.h90" 
     102#     undef ROUTINE_NFD 
     103#     define MULTI 
     104#     define ROUTINE_NFD           lbc_nfd_3d_ptr 
     105#     include "lbc_nfd_generic.h90" 
     106#     undef ROUTINE_NFD 
     107#     undef MULTI 
     108#  undef DIM_3d 
     109   ! 
     110   !                       !==  4D array and array of 4D pointer  ==! 
     111   ! 
     112#  define DIM_4d 
     113#     define ROUTINE_NFD           lbc_nfd_4d 
     114#     include "lbc_nfd_generic.h90" 
     115#     undef ROUTINE_NFD 
     116#     define MULTI 
     117#     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     118#     include "lbc_nfd_generic.h90" 
     119#     undef ROUTINE_NFD 
     120#     undef MULTI 
     121#  undef DIM_4d 
     122   ! 
     123   !  lbc_nfd_nogather routines 
     124   ! 
     125   !                       !==  2D array and array of 2D pointer  ==! 
     126   ! 
     127!#  define DIM_2d 
     128!#     define ROUTINE_NFD           lbc_nfd_nogather_2d 
     129!#     include "lbc_nfd_nogather_generic.h90" 
     130!#     undef ROUTINE_NFD 
     131!#     define MULTI 
     132!#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
     133!#     include "lbc_nfd_nogather_generic.h90" 
     134!#     undef ROUTINE_NFD 
     135!#     undef MULTI 
     136!#  undef DIM_2d 
     137   ! 
     138   !                       !==  3D array and array of 3D pointer  ==! 
     139   ! 
     140!#  define DIM_3d 
     141!#     define ROUTINE_NFD           lbc_nfd_nogather_3d 
     142!#     include "lbc_nfd_nogather_generic.h90" 
     143!#     undef ROUTINE_NFD 
     144!#     define MULTI 
     145!#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
     146!#     include "lbc_nfd_nogather_generic.h90" 
     147!#     undef ROUTINE_NFD 
     148!#     undef MULTI 
     149!#  undef DIM_3d 
     150   ! 
     151   !                       !==  4D array and array of 4D pointer  ==! 
     152   ! 
     153#  define DIM_4d 
     154#     define ROUTINE_NFD           lbc_nfd_nogather_4d 
     155#     include "lbc_nfd_nogather_generic.h90" 
     156#     undef ROUTINE_NFD 
     157!#     define MULTI 
     158!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
     159!#     include "lbc_nfd_nogather_generic.h90" 
     160!#     undef ROUTINE_NFD 
     161!#     undef MULTI 
     162#  undef DIM_4d 
    66163 
    67       SELECT CASE ( jpni ) 
    68       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    69       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    70       END SELECT 
    71       ijpjm1 = ijpj-1 
     164   !!---------------------------------------------------------------------- 
    72165 
    73       DO jk = 1, jpk 
    74          ! 
    75          SELECT CASE ( npolj ) 
    76          ! 
    77          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    78             ! 
    79             SELECT CASE ( cd_type ) 
    80             CASE ( 'T' , 'W' )                         ! T-, W-point 
    81                DO ji = 2, jpiglo 
    82                   ijt = jpiglo-ji+2 
    83                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    84                END DO 
    85                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 
    86                DO ji = jpiglo/2+1, jpiglo 
    87                   ijt = jpiglo-ji+2 
    88                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    89                END DO 
    90             CASE ( 'U' )                               ! U-point 
    91                DO ji = 1, jpiglo-1 
    92                   iju = jpiglo-ji+1 
    93                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    94                END DO 
    95                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-2,jk) 
    96                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk)  
    97                DO ji = jpiglo/2, jpiglo-1 
    98                   iju = jpiglo-ji+1 
    99                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    100                END DO 
    101             CASE ( 'V' )                               ! V-point 
    102                DO ji = 2, jpiglo 
    103                   ijt = jpiglo-ji+2 
    104                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    105                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
    106                END DO 
    107                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk)  
    108             CASE ( 'F' )                               ! F-point 
    109                DO ji = 1, jpiglo-1 
    110                   iju = jpiglo-ji+1 
    111                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    112                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
    113                END DO 
    114                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-3,jk) 
    115                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk)  
    116             END SELECT 
    117             ! 
    118          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    119             ! 
    120             SELECT CASE ( cd_type ) 
    121             CASE ( 'T' , 'W' )                         ! T-, W-point 
    122                DO ji = 1, jpiglo 
    123                   ijt = jpiglo-ji+1 
    124                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
    125                END DO 
    126             CASE ( 'U' )                               ! U-point 
    127                DO ji = 1, jpiglo-1 
    128                   iju = jpiglo-ji 
    129                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
    130                END DO 
    131                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 
    132             CASE ( 'V' )                               ! V-point 
    133                DO ji = 1, jpiglo 
    134                   ijt = jpiglo-ji+1 
    135                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    136                END DO 
    137                DO ji = jpiglo/2+1, jpiglo 
    138                   ijt = jpiglo-ji+1 
    139                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    140                END DO 
    141             CASE ( 'F' )                               ! F-point 
    142                DO ji = 1, jpiglo-1 
    143                   iju = jpiglo-ji 
    144                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    145                END DO 
    146                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 
    147                DO ji = jpiglo/2+1, jpiglo-1 
    148                   iju = jpiglo-ji 
    149                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    150                END DO 
    151             END SELECT 
    152             ! 
    153          CASE DEFAULT                           ! *  closed : the code probably never go through 
    154             ! 
    155             SELECT CASE ( cd_type) 
    156             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    157                pt3d(:, 1  ,jk) = 0.e0 
    158                pt3d(:,ijpj,jk) = 0.e0 
    159             CASE ( 'F' )                               ! F-point 
    160                pt3d(:,ijpj,jk) = 0.e0 
    161             END SELECT 
    162             ! 
    163          END SELECT     !  npolj 
    164          ! 
    165       END DO 
    166       ! 
    167    END SUBROUTINE lbc_nfd_3d 
    168  
    169  
    170    SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 
    171       !!---------------------------------------------------------------------- 
    172       !!                  ***  routine lbc_nfd_2d  *** 
    173       !! 
    174       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    175       !!       without processor exchanges.  
    176       !! 
    177       !! ** Method  :    
    178       !! 
    179       !! ** Action  :   pt2d with updated values along the north fold 
    180       !!---------------------------------------------------------------------- 
    181       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    182       !                                                      ! = T , U , V , F , W points 
    183       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    184       !                                                      !   = -1. , the sign is changed if north fold boundary 
    185       !                                                      !   =  1. , the sign is kept  if north fold boundary 
    186       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
    187       INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
    188       ! 
    189       INTEGER  ::   ji, jl, ipr2dj 
    190       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    191       !!---------------------------------------------------------------------- 
    192  
    193       SELECT CASE ( jpni ) 
    194       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    195       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    196       END SELECT 
    197       ! 
    198       IF( PRESENT(pr2dj) ) THEN           ! use of additional halos 
    199          ipr2dj = pr2dj 
    200          IF( jpni > 1 )   ijpj = ijpj + ipr2dj 
    201       ELSE 
    202          ipr2dj = 0  
    203       ENDIF 
    204       ! 
    205       ijpjm1 = ijpj-1 
    206  
    207  
    208       SELECT CASE ( npolj ) 
    209       ! 
    210       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    211          ! 
    212          SELECT CASE ( cd_type ) 
    213          ! 
    214          CASE ( 'T' , 'W' )                               ! T- , W-points 
    215             DO jl = 0, ipr2dj 
    216                DO ji = 2, jpiglo 
    217                   ijt=jpiglo-ji+2 
    218                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) 
    219                END DO 
    220             END DO 
    221             pt2d(1,ijpj)   = psgn * pt2d(3,ijpj-2) 
    222             DO ji = jpiglo/2+1, jpiglo 
    223                ijt=jpiglo-ji+2 
    224                pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1) 
    225             END DO 
    226          CASE ( 'U' )                                     ! U-point 
    227             DO jl = 0, ipr2dj 
    228                DO ji = 1, jpiglo-1 
    229                   iju = jpiglo-ji+1 
    230                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) 
    231                END DO 
    232             END DO 
    233             pt2d(   1  ,ijpj  ) = psgn * pt2d(    2   ,ijpj-2) 
    234             pt2d(jpiglo,ijpj  ) = psgn * pt2d(jpiglo-1,ijpj-2) 
    235             pt2d(1     ,ijpj-1) = psgn * pt2d(jpiglo  ,ijpj-1)    
    236             DO ji = jpiglo/2, jpiglo-1 
    237                iju = jpiglo-ji+1 
    238                pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) 
    239             END DO 
    240          CASE ( 'V' )                                     ! V-point 
    241             DO jl = -1, ipr2dj 
    242                DO ji = 2, jpiglo 
    243                   ijt = jpiglo-ji+2 
    244                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl) 
    245                END DO 
    246             END DO 
    247             pt2d( 1 ,ijpj)   = psgn * pt2d( 3 ,ijpj-3)  
    248          CASE ( 'F' )                                     ! F-point 
    249             DO jl = -1, ipr2dj 
    250                DO ji = 1, jpiglo-1 
    251                   iju = jpiglo-ji+1 
    252                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl) 
    253                END DO 
    254             END DO 
    255             pt2d(   1  ,ijpj)   = psgn * pt2d(    2   ,ijpj-3) 
    256             pt2d(jpiglo,ijpj)   = psgn * pt2d(jpiglo-1,ijpj-3) 
    257             pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)       
    258             pt2d(   1  ,ijpj-1) = psgn * pt2d(    2   ,ijpj-2)       
    259          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    260             DO jl = 0, ipr2dj 
    261                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    262                DO ji = 3, jpiglo 
    263                   iju = jpiglo - ji + 3 
    264                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    265                END DO 
    266             END DO 
    267          CASE ( 'J' )                                     ! first ice U-V point 
    268             DO jl =0, ipr2dj 
    269                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    270                DO ji = 3, jpiglo 
    271                   iju = jpiglo - ji + 3 
    272                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    273                END DO 
    274             END DO 
    275          CASE ( 'K' )                                     ! second ice U-V point 
    276             DO jl =0, ipr2dj 
    277                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    278                DO ji = 3, jpiglo 
    279                   iju = jpiglo - ji + 3 
    280                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    281                END DO 
    282             END DO 
    283          END SELECT 
    284          ! 
    285       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    286          ! 
    287          SELECT CASE ( cd_type ) 
    288          CASE ( 'T' , 'W' )                               ! T-, W-point 
    289             DO jl = 0, ipr2dj 
    290                DO ji = 1, jpiglo 
    291                   ijt = jpiglo-ji+1 
    292                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl) 
    293                END DO 
    294             END DO 
    295          CASE ( 'U' )                                     ! U-point 
    296             DO jl = 0, ipr2dj 
    297                DO ji = 1, jpiglo-1 
    298                   iju = jpiglo-ji 
    299                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    300                END DO 
    301             END DO 
    302             pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1) 
    303          CASE ( 'V' )                                     ! V-point 
    304             DO jl = 0, ipr2dj 
    305                DO ji = 1, jpiglo 
    306                   ijt = jpiglo-ji+1 
    307                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) 
    308                END DO 
    309             END DO 
    310             DO ji = jpiglo/2+1, jpiglo 
    311                ijt = jpiglo-ji+1 
    312                pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1) 
    313             END DO 
    314          CASE ( 'F' )                               ! F-point 
    315             DO jl = 0, ipr2dj 
    316                DO ji = 1, jpiglo-1 
    317                   iju = jpiglo-ji 
    318                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) 
    319                END DO 
    320             END DO 
    321             pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2) 
    322             DO ji = jpiglo/2+1, jpiglo-1 
    323                iju = jpiglo-ji 
    324                pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) 
    325             END DO 
    326          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    327             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    328             DO jl = 0, ipr2dj 
    329                DO ji = 2 , jpiglo-1 
    330                   ijt = jpiglo - ji + 2 
    331                   pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) ) 
    332                END DO 
    333             END DO 
    334          CASE ( 'J' )                                  ! first ice U-V point 
    335             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    336             DO jl = 0, ipr2dj 
    337                DO ji = 2 , jpiglo-1 
    338                   ijt = jpiglo - ji + 2 
    339                   pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) 
    340                END DO 
    341             END DO 
    342          CASE ( 'K' )                                  ! second ice U-V point 
    343             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    344             DO jl = 0, ipr2dj 
    345                DO ji = 2 , jpiglo-1 
    346                   ijt = jpiglo - ji + 2 
    347                   pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) 
    348                END DO 
    349             END DO 
    350          END SELECT 
    351          ! 
    352       CASE DEFAULT                           ! *  closed : the code probably never go through 
    353          ! 
    354          SELECT CASE ( cd_type) 
    355          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    356             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    357             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    358          CASE ( 'F' )                                   ! F-point 
    359             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    360          CASE ( 'I' )                                   ! ice U-V point 
    361             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    362             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    363          CASE ( 'J' )                                   ! first ice U-V point 
    364             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    365             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    366          CASE ( 'K' )                                   ! second ice U-V point 
    367             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    368             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    369          END SELECT 
    370          ! 
    371       END SELECT 
    372       ! 
    373    END SUBROUTINE lbc_nfd_2d 
    374  
    375  
    376    SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 
    377       !!---------------------------------------------------------------------- 
    378       !!                  ***  routine mpp_lbc_nfd_3d  *** 
    379       !! 
    380       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    381       !!              without processor exchanges.  
    382       !! 
    383       !! ** Method  :    
    384       !! 
    385       !! ** Action  :   pt3d with updated values along the north fold 
    386       !!---------------------------------------------------------------------- 
    387       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    388       !                                                        !   = T , U , V , F , W points 
    389       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    390       !                                                        !   = -1. , the sign is changed if north fold boundary 
    391       !                                                        !   =  1. , the sign is kept    if north fold boundary 
    392       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied 
    393       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied 
    394       ! 
    395       INTEGER  ::   ji, jk 
    396       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    397       !!---------------------------------------------------------------------- 
    398       ! 
    399       SELECT CASE ( jpni ) 
    400       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    401       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    402       END SELECT 
    403       ijpjm1 = ijpj-1 
    404  
    405          ! 
    406          SELECT CASE ( npolj ) 
    407          ! 
    408          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    409             ! 
    410             SELECT CASE ( cd_type ) 
    411             CASE ( 'T' , 'W' )                         ! T-, W-point 
    412                IF (nimpp .ne. 1) THEN 
    413                  startloop = 1 
    414                ELSE 
    415                  startloop = 2 
    416                ENDIF 
    417  
    418                DO jk = 1, jpk 
    419                   DO ji = startloop, nlci 
    420                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    421                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    422                   END DO 
    423                   IF(nimpp .eq. 1) THEN 
    424                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 
    425                   ENDIF 
    426                END DO 
    427  
    428                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    429                  startloop = 1 
    430                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    431                  startloop = jpiglo/2+1 - nimpp + 1 
    432                ELSE 
    433                  startloop = nlci + 1 
    434                ENDIF 
    435                IF(startloop .le. nlci) THEN 
    436                  DO jk = 1, jpk 
    437                     DO ji = startloop, nlci 
    438                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    439                        jia = ji + nimpp - 1 
    440                        ijta = jpiglo - jia + 2 
    441                        IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
    442                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
    443                        ELSE 
    444                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    445                        ENDIF 
    446                     END DO 
    447                  END DO 
    448                ENDIF 
    449  
    450  
    451             CASE ( 'U' )                               ! U-point 
    452                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    453                   endloop = nlci 
    454                ELSE 
    455                   endloop = nlci - 1 
    456                ENDIF 
    457                DO jk = 1, jpk 
    458                   DO ji = 1, endloop 
    459                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    460                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    461                   END DO 
    462                   IF(nimpp .eq. 1) THEN 
    463                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk) 
    464                   ENDIF 
    465                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    466                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 
    467                   ENDIF 
    468                END DO 
    469  
    470                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    471                   endloop = nlci 
    472                ELSE 
    473                   endloop = nlci - 1 
    474                ENDIF 
    475                IF(nimpp .ge. (jpiglo/2)) THEN 
    476                   startloop = 1 
    477                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
    478                   startloop = jpiglo/2 - nimpp + 1 
    479                ELSE 
    480                   startloop = endloop + 1 
    481                ENDIF 
    482                IF (startloop .le. endloop) THEN 
    483                  DO jk = 1, jpk 
    484                     DO ji = startloop, endloop 
    485                       iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    486                       jia = ji + nimpp - 1 
    487                       ijua = jpiglo - jia + 1 
    488                       IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
    489                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
    490                       ELSE 
    491                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    492                       ENDIF 
    493                     END DO 
    494                  END DO 
    495                ENDIF 
    496  
    497             CASE ( 'V' )                               ! V-point 
    498                IF (nimpp .ne. 1) THEN 
    499                   startloop = 1 
    500                ELSE 
    501                   startloop = 2 
    502                ENDIF 
    503                DO jk = 1, jpk 
    504                   DO ji = startloop, nlci 
    505                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    506                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    507                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
    508                   END DO 
    509                   IF(nimpp .eq. 1) THEN 
    510                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 
    511                   ENDIF 
    512                END DO 
    513             CASE ( 'F' )                               ! F-point 
    514                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    515                   endloop = nlci 
    516                ELSE 
    517                   endloop = nlci - 1 
    518                ENDIF 
    519                DO jk = 1, jpk 
    520                   DO ji = 1, endloop 
    521                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    522                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    523                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
    524                   END DO 
    525                   IF(nimpp .eq. 1) THEN 
    526                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk) 
    527                   ENDIF 
    528                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    529                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 
    530                   ENDIF 
    531                END DO 
    532             END SELECT 
    533             ! 
    534  
    535          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    536             ! 
    537             SELECT CASE ( cd_type ) 
    538             CASE ( 'T' , 'W' )                         ! T-, W-point 
    539                DO jk = 1, jpk 
    540                   DO ji = 1, nlci 
    541                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    542                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
    543                   END DO 
    544                END DO 
    545  
    546             CASE ( 'U' )                               ! U-point 
    547                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    548                   endloop = nlci 
    549                ELSE 
    550                   endloop = nlci - 1 
    551                ENDIF 
    552                DO jk = 1, jpk 
    553                   DO ji = 1, endloop 
    554                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    555                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
    556                   END DO 
    557                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    558                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 
    559                   ENDIF 
    560                END DO 
    561  
    562             CASE ( 'V' )                               ! V-point 
    563                DO jk = 1, jpk 
    564                   DO ji = 1, nlci 
    565                      ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
    566                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    567                   END DO 
    568                END DO 
    569  
    570                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    571                   startloop = 1 
    572                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    573                   startloop = jpiglo/2+1 - nimpp + 1 
    574                ELSE 
    575                   startloop = nlci + 1 
    576                ENDIF 
    577                IF(startloop .le. nlci) THEN 
    578                  DO jk = 1, jpk 
    579                     DO ji = startloop, nlci 
    580                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    581                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    582                     END DO 
    583                  END DO 
    584                ENDIF 
    585  
    586             CASE ( 'F' )                               ! F-point 
    587                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    588                   endloop = nlci 
    589                ELSE 
    590                   endloop = nlci - 1 
    591                ENDIF 
    592                DO jk = 1, jpk 
    593                   DO ji = 1, endloop 
    594                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    595                      pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    596                   END DO 
    597                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    598                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 
    599                   ENDIF 
    600                END DO 
    601  
    602                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    603                   endloop = nlci 
    604                ELSE 
    605                   endloop = nlci - 1 
    606                ENDIF 
    607                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    608                   startloop = 1 
    609                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    610                   startloop = jpiglo/2+1 - nimpp + 1 
    611                ELSE 
    612                   startloop = endloop + 1 
    613                ENDIF 
    614                IF (startloop .le. endloop) THEN 
    615                   DO jk = 1, jpk 
    616                      DO ji = startloop, endloop 
    617                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    618                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    619                      END DO 
    620                   END DO 
    621                ENDIF 
    622  
    623             END SELECT 
    624  
    625          CASE DEFAULT                           ! *  closed : the code probably never go through 
    626             ! 
    627             SELECT CASE ( cd_type) 
    628             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    629                pt3dl(:, 1  ,jk) = 0.e0 
    630                pt3dl(:,ijpj,jk) = 0.e0 
    631             CASE ( 'F' )                               ! F-point 
    632                pt3dl(:,ijpj,jk) = 0.e0 
    633             END SELECT 
    634             ! 
    635          END SELECT     !  npolj 
    636          ! 
    637       ! 
    638    END SUBROUTINE mpp_lbc_nfd_3d 
    639  
    640  
    641    SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 
    642       !!---------------------------------------------------------------------- 
    643       !!                  ***  routine mpp_lbc_nfd_2d  *** 
    644       !! 
    645       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    646       !!       without processor exchanges.  
    647       !! 
    648       !! ** Method  :    
    649       !! 
    650       !! ** Action  :   pt2d with updated values along the north fold 
    651       !!---------------------------------------------------------------------- 
    652       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    653       !                                                      ! = T , U , V , F , W points 
    654       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    655       !                                                      !   = -1. , the sign is changed if north fold boundary 
    656       !                                                      !   =  1. , the sign is kept  if north fold boundary 
    657       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied 
    658       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied 
    659       ! 
    660       INTEGER  ::   ji 
    661       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    662       !!---------------------------------------------------------------------- 
    663  
    664       SELECT CASE ( jpni ) 
    665       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    666       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    667       END SELECT 
    668       ! 
    669       ijpjm1 = ijpj-1 
    670  
    671  
    672       SELECT CASE ( npolj ) 
    673       ! 
    674       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    675          ! 
    676          SELECT CASE ( cd_type ) 
    677          ! 
    678          CASE ( 'T' , 'W' )                               ! T- , W-points 
    679             IF (nimpp .ne. 1) THEN 
    680               startloop = 1 
    681             ELSE 
    682               startloop = 2 
    683             ENDIF 
    684             DO ji = startloop, nlci 
    685               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    686               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    687             END DO 
    688             IF (nimpp .eq. 1) THEN 
    689               pt2dl(1,ijpj)   = psgn * pt2dl(3,ijpj-2) 
    690             ENDIF 
    691  
    692             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    693                startloop = 1 
    694             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    695                startloop = jpiglo/2+1 - nimpp + 1 
    696             ELSE 
    697                startloop = nlci + 1 
    698             ENDIF 
    699             DO ji = startloop, nlci 
    700                ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    701                jia = ji + nimpp - 1 
    702                ijta = jpiglo - jia + 2 
    703                IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
    704                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
    705                ELSE 
    706                   pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    707                ENDIF 
    708             END DO 
    709  
    710          CASE ( 'U' )                                     ! U-point 
    711             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    712                endloop = nlci 
    713             ELSE 
    714                endloop = nlci - 1 
    715             ENDIF 
    716             DO ji = 1, endloop 
    717                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    718                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    719             END DO 
    720  
    721             IF (nimpp .eq. 1) THEN 
    722               pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
    723               pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 
    724             ENDIF 
    725             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    726               pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
    727             ENDIF 
    728  
    729             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    730                endloop = nlci 
    731             ELSE 
    732                endloop = nlci - 1 
    733             ENDIF 
    734             IF(nimpp .ge. (jpiglo/2)) THEN 
    735                startloop = 1 
    736             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
    737                startloop = jpiglo/2 - nimpp + 1 
    738             ELSE 
    739                startloop = endloop + 1 
    740             ENDIF 
    741             DO ji = startloop, endloop 
    742                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    743                jia = ji + nimpp - 1 
    744                ijua = jpiglo - jia + 1 
    745                IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
    746                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
    747                ELSE 
    748                   pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    749                ENDIF 
    750             END DO 
    751  
    752          CASE ( 'V' )                                     ! V-point 
    753             IF (nimpp .ne. 1) THEN 
    754               startloop = 1 
    755             ELSE 
    756               startloop = 2 
    757             ENDIF 
    758             DO ji = startloop, nlci 
    759               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    760               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
    761               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
    762             END DO 
    763             IF (nimpp .eq. 1) THEN 
    764               pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
    765             ENDIF 
    766  
    767          CASE ( 'F' )                                     ! F-point 
    768             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    769                endloop = nlci 
    770             ELSE 
    771                endloop = nlci - 1 
    772             ENDIF 
    773             DO ji = 1, endloop 
    774                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    775                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
    776                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
    777             END DO 
    778             IF (nimpp .eq. 1) THEN 
    779               pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3) 
    780               pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2) 
    781             ENDIF 
    782             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    783               pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3) 
    784               pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
    785             ENDIF 
    786  
    787          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    788             IF (nimpp .ne. 1) THEN 
    789                startloop = 1 
    790             ELSE 
    791                startloop = 3 
    792                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
    793             ENDIF 
    794             DO ji = startloop, nlci 
    795                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    796                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    797             END DO 
    798  
    799          CASE ( 'J' )                                     ! first ice U-V point 
    800             IF (nimpp .ne. 1) THEN 
    801                startloop = 1 
    802             ELSE 
    803                startloop = 3 
    804                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    805             ENDIF 
    806             DO ji = startloop, nlci 
    807                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    808                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    809             END DO 
    810  
    811          CASE ( 'K' )                                     ! second ice U-V point 
    812             IF (nimpp .ne. 1) THEN 
    813                startloop = 1 
    814             ELSE 
    815                startloop = 3 
    816                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    817             ENDIF 
    818             DO ji = startloop, nlci 
    819                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    820                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    821             END DO 
    822  
    823          END SELECT 
    824          ! 
    825       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    826          ! 
    827          SELECT CASE ( cd_type ) 
    828          CASE ( 'T' , 'W' )                               ! T-, W-point 
    829             DO ji = 1, nlci 
    830                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    831                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    832             END DO 
    833  
    834          CASE ( 'U' )                                     ! U-point 
    835             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    836                endloop = nlci 
    837             ELSE 
    838                endloop = nlci - 1 
    839             ENDIF 
    840             DO ji = 1, endloop 
    841                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    842                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    843             END DO 
    844             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    845                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
    846             ENDIF 
    847  
    848          CASE ( 'V' )                                     ! V-point 
    849             DO ji = 1, nlci 
    850                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    851                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    852             END DO 
    853             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    854                startloop = 1 
    855             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    856                startloop = jpiglo/2+1 - nimpp + 1 
    857             ELSE 
    858                startloop = nlci + 1 
    859             ENDIF 
    860             DO ji = startloop, nlci 
    861                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    862                pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    863             END DO 
    864  
    865          CASE ( 'F' )                               ! F-point 
    866             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    867                endloop = nlci 
    868             ELSE 
    869                endloop = nlci - 1 
    870             ENDIF 
    871             DO ji = 1, endloop 
    872                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    873                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    874             END DO 
    875             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    876                 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
    877             ENDIF 
    878  
    879             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    880                endloop = nlci 
    881             ELSE 
    882                endloop = nlci - 1 
    883             ENDIF 
    884             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    885                startloop = 1 
    886             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    887                startloop = jpiglo/2+1 - nimpp + 1 
    888             ELSE 
    889                startloop = endloop + 1 
    890             ENDIF 
    891  
    892             DO ji = startloop, endloop 
    893                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    894                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    895             END DO 
    896  
    897          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    898                IF (nimpp .ne. 1) THEN 
    899                   startloop = 1 
    900                ELSE 
    901                   startloop = 2 
    902                ENDIF 
    903                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    904                   endloop = nlci 
    905                ELSE 
    906                   endloop = nlci - 1 
    907                ENDIF 
    908                DO ji = startloop , endloop 
    909                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    910                   pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    911                END DO 
    912  
    913          CASE ( 'J' )                                  ! first ice U-V point 
    914                IF (nimpp .ne. 1) THEN 
    915                   startloop = 1 
    916                ELSE 
    917                   startloop = 2 
    918                ENDIF 
    919                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    920                   endloop = nlci 
    921                ELSE 
    922                   endloop = nlci - 1 
    923                ENDIF 
    924                DO ji = startloop , endloop 
    925                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    926                   pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 
    927                END DO 
    928  
    929          CASE ( 'K' )                                  ! second ice U-V point 
    930                IF (nimpp .ne. 1) THEN 
    931                   startloop = 1 
    932                ELSE 
    933                   startloop = 2 
    934                ENDIF 
    935                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    936                   endloop = nlci 
    937                ELSE 
    938                   endloop = nlci - 1 
    939                ENDIF 
    940                DO ji = startloop, endloop 
    941                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    942                   pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 
    943                END DO 
    944  
    945          END SELECT 
    946          ! 
    947       CASE DEFAULT                           ! *  closed : the code probably never go through 
    948          ! 
    949          SELECT CASE ( cd_type) 
    950          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    951             pt2dl(:, 1     ) = 0.e0 
    952             pt2dl(:,ijpj) = 0.e0 
    953          CASE ( 'F' )                                   ! F-point 
    954             pt2dl(:,ijpj) = 0.e0 
    955          CASE ( 'I' )                                   ! ice U-V point 
    956             pt2dl(:, 1     ) = 0.e0 
    957             pt2dl(:,ijpj) = 0.e0 
    958          CASE ( 'J' )                                   ! first ice U-V point 
    959             pt2dl(:, 1     ) = 0.e0 
    960             pt2dl(:,ijpj) = 0.e0 
    961          CASE ( 'K' )                                   ! second ice U-V point 
    962             pt2dl(:, 1     ) = 0.e0 
    963             pt2dl(:,ijpj) = 0.e0 
    964          END SELECT 
    965          ! 
    966       END SELECT 
    967       ! 
    968    END SUBROUTINE mpp_lbc_nfd_2d 
    969166 
    970167   !!====================================================================== 
Note: See TracChangeset for help on using the changeset viewer.