Changeset 8811


Ignore:
Timestamp:
2017-11-24T17:22:26+01:00 (3 years ago)
Author:
acc
Message:

Branch 2017/dev_r8126_ROBUST08_no_ghost. Cleaning of lib_mpp.F90 and reactivation of extended halo exchanges for icb only. mpp_lnk_2d_icb remains the only extended-halo exchange routine and is accessed via the generic routine: lbc_lnk_icb. This should be viewed as a temporary solution pending extended halo capabilities being added to all lbc_lnk routines. mpp_lnk_2d_icb does not support the ln_nnogather optimisation and uses its own alternative to mpp_nfd (mpp_lbc_north_icb) to handle the north-fold. This, in turn, uses an extended halo version of lbc_nfd which is, currently, maintained separately in a new include file: lbc_nfd_ext_generic.h90 (included in lbcnfd.F90). These changes compile, run and pass all SETTE tests but full verification awaits a test that actually passes icebergs across the north-fold

Location:
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r8186 r8811  
    2121   !!---------------------------------------------------------------------- 
    2222   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    23    !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    2423   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2524   !!---------------------------------------------------------------------- 
     
    4241   END INTERFACE 
    4342   ! 
    44    INTERFACE lbc_lnk_e 
    45       MODULE PROCEDURE mpp_lnk_2d_e 
    46    END INTERFACE 
    47    ! 
    4843   INTERFACE lbc_lnk_icb 
    4944      MODULE PROCEDURE mpp_lnk_2d_icb 
     
    5247   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    5348   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    54    PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    5549   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    5650   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     
    9589   END INTERFACE 
    9690   ! 
    97    INTERFACE lbc_lnk_e 
    98       MODULE PROCEDURE lbc_lnk_2d_e 
    99    END INTERFACE 
    100    ! 
    10191   INTERFACE lbc_bdy_lnk 
    10292      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    10494   ! 
    10595   INTERFACE lbc_lnk_icb 
    106       MODULE PROCEDURE lbc_lnk_2d_e 
     96      MODULE PROCEDURE lbc_lnk_2d_icb 
    10797   END INTERFACE 
    10898    
    10999   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    110    PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    111100   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    112101   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
     
    270259 
    271260 
    272 !!gm  This routine should be remove with an optional halos size added in orgument of generic routines 
    273  
    274    SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 
     261!!gm  This routine should be removed with an optional halos size added in argument of generic routines 
     262 
     263   SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj ) 
    275264      !!---------------------------------------------------------------------- 
    276265      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
     
    280269      !!---------------------------------------------------------------------- 
    281270      CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
    282    END SUBROUTINE lbc_lnk_2d_e 
     271   END SUBROUTINE lbc_lnk_2d_icb 
    283272!!gm end 
    284273 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r8196 r8811  
    2727      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
    2828      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
     29      MODULE PROCEDURE   lbc_nfd_2d_ext 
    2930   END INTERFACE 
    3031   ! 
     
    8485#     undef ROUTINE_NFD 
    8586#     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 
    8695#  undef DIM_2d 
    8796   ! 
     
    156165 
    157166 
    158 !!gm   CAUTION HERE  optional pr2dj  not implemented in generic case 
    159 !!gm                 furthermore, in the _org routine it is OK only for T-point pivot !! 
    160  
    161  
    162    SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 
    163       !!---------------------------------------------------------------------- 
    164       !!                  ***  routine lbc_nfd_2d  *** 
    165       !! 
    166       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    167       !!       without processor exchanges.  
    168       !! 
    169       !! ** Method  :    
    170       !! 
    171       !! ** Action  :   pt2d with updated values along the north fold 
    172       !!---------------------------------------------------------------------- 
    173       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
    174       CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point 
    175       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    176       INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
    177       ! 
    178       INTEGER  ::   ji, jl, ipr2dj 
    179       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    180       !!---------------------------------------------------------------------- 
    181  
    182       SELECT CASE ( jpni ) 
    183       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    184       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    185       END SELECT 
    186       ! 
    187       IF( PRESENT(pr2dj) ) THEN           ! use of additional halos 
    188          ipr2dj = pr2dj 
    189          IF( jpni > 1 )   ijpj = ijpj + ipr2dj 
    190       ELSE 
    191          ipr2dj = 0  
    192       ENDIF 
    193       ! 
    194       ijpjm1 = ijpj-1 
    195  
    196  
    197       SELECT CASE ( npolj ) 
    198       ! 
    199       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    200          ! 
    201          SELECT CASE ( cd_nat ) 
    202          ! 
    203          CASE ( 'T' , 'W' )                               ! T- , W-points 
    204             DO jl = 0, ipr2dj 
    205                DO ji = 2, jpiglo 
    206                   ijt=jpiglo-ji+2 
    207                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) 
    208                END DO 
    209             END DO 
    210             pt2d(1,ijpj)   = psgn * pt2d(3,ijpj-2) 
    211             DO ji = jpiglo/2+1, jpiglo 
    212                ijt=jpiglo-ji+2 
    213                pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1) 
    214             END DO 
    215          CASE ( 'U' )                                     ! U-point 
    216             DO jl = 0, ipr2dj 
    217                DO ji = 1, jpiglo-1 
    218                   iju = jpiglo-ji+1 
    219                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) 
    220                END DO 
    221             END DO 
    222             pt2d(   1  ,ijpj  ) = psgn * pt2d(    2   ,ijpj-2) 
    223             pt2d(jpiglo,ijpj  ) = psgn * pt2d(jpiglo-1,ijpj-2) 
    224             pt2d(1     ,ijpj-1) = psgn * pt2d(jpiglo  ,ijpj-1)    
    225             DO ji = jpiglo/2, jpiglo-1 
    226                iju = jpiglo-ji+1 
    227                pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) 
    228             END DO 
    229          CASE ( 'V' )                                     ! V-point 
    230             DO jl = -1, ipr2dj 
    231                DO ji = 2, jpiglo 
    232                   ijt = jpiglo-ji+2 
    233                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl) 
    234                END DO 
    235             END DO 
    236             pt2d( 1 ,ijpj)   = psgn * pt2d( 3 ,ijpj-3)  
    237          CASE ( 'F' )                                     ! F-point 
    238             DO jl = -1, ipr2dj 
    239                DO ji = 1, jpiglo-1 
    240                   iju = jpiglo-ji+1 
    241                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl) 
    242                END DO 
    243             END DO 
    244             pt2d(   1  ,ijpj)   = psgn * pt2d(    2   ,ijpj-3) 
    245             pt2d(jpiglo,ijpj)   = psgn * pt2d(jpiglo-1,ijpj-3) 
    246             pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)       
    247             pt2d(   1  ,ijpj-1) = psgn * pt2d(    2   ,ijpj-2)       
    248          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    249             DO jl = 0, ipr2dj 
    250                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    251                DO ji = 3, jpiglo 
    252                   iju = jpiglo - ji + 3 
    253                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    254                END DO 
    255             END DO 
    256          END SELECT 
    257          ! 
    258       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    259          ! 
    260          SELECT CASE ( cd_nat ) 
    261          CASE ( 'T' , 'W' )                               ! T-, W-point 
    262             DO jl = 0, ipr2dj 
    263                DO ji = 1, jpiglo 
    264                   ijt = jpiglo-ji+1 
    265                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl) 
    266                END DO 
    267             END DO 
    268          CASE ( 'U' )                                     ! U-point 
    269             DO jl = 0, ipr2dj 
    270                DO ji = 1, jpiglo-1 
    271                   iju = jpiglo-ji 
    272                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    273                END DO 
    274             END DO 
    275             pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1) 
    276          CASE ( 'V' )                                     ! V-point 
    277             DO jl = 0, ipr2dj 
    278                DO ji = 1, jpiglo 
    279                   ijt = jpiglo-ji+1 
    280                   pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) 
    281                END DO 
    282             END DO 
    283             DO ji = jpiglo/2+1, jpiglo 
    284                ijt = jpiglo-ji+1 
    285                pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1) 
    286             END DO 
    287          CASE ( 'F' )                               ! F-point 
    288             DO jl = 0, ipr2dj 
    289                DO ji = 1, jpiglo-1 
    290                   iju = jpiglo-ji 
    291                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) 
    292                END DO 
    293             END DO 
    294             pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2) 
    295             DO ji = jpiglo/2+1, jpiglo-1 
    296                iju = jpiglo-ji 
    297                pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) 
    298             END DO 
    299          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    300             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 
    301             DO jl = 0, ipr2dj 
    302                DO ji = 2 , jpiglo-1 
    303                   ijt = jpiglo - ji + 2 
    304                   pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) ) 
    305                END DO 
    306             END DO 
    307          END SELECT 
    308          ! 
    309       CASE DEFAULT                           ! *  closed : the code probably never go through 
    310          ! 
    311          SELECT CASE ( cd_nat) 
    312          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    313             pt2d(:, 1:1-ipr2dj     ) = 0._wp 
    314             pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    315          CASE ( 'F' )                                   ! F-point 
    316             pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    317          CASE ( 'I' )                                   ! ice U-V point 
    318             pt2d(:, 1:1-ipr2dj     ) = 0._wp 
    319             pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    320          END SELECT 
    321          ! 
    322       END SELECT 
    323       ! 
    324    END SUBROUTINE lbc_nfd_2d_org 
    325  
    326167   !!====================================================================== 
    327168END MODULE lbcnfd 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r8809 r8811  
    4141   !!   mynode        : indentify the processor unit 
    4242   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    43    !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4443   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    4544   !!   mpprecv       : 
     
    5554   !!   mppstop       : 
    5655   !!   mpp_ini_north : initialisation of north fold 
    57 !!gm   !!   mpp_lbc_north : north fold processors gathering 
    58    !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    59    !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
     56   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 
    6057   !!---------------------------------------------------------------------- 
    6158   USE dom_oce        ! ocean space and time domain 
     
    7572   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
    7673   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
    77    PUBLIC   mpp_lnk_2d_e 
    7874   ! 
    7975!!gm  this should be useless 
     
    8480   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    8581   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    86    PUBLIC   mpp_ini_north, mpp_lbc_north_e 
    87 !!gm   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    88    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     82   PUBLIC   mpp_ini_north 
     83   PUBLIC   mpp_lnk_2d_icb 
     84   PUBLIC   mpp_lbc_north_icb 
    8985   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    9086   PUBLIC   mpp_max_multiple 
    91 !!gm   PUBLIC   mpp_lnk_2d_9  
    92 !!gm   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    9387   PUBLIC   mppscatter, mppgather 
    9488   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    112106         &             mppsum_realdd, mppsum_a_realdd 
    113107   END INTERFACE 
    114 !!gm   INTERFACE mpp_lbc_north 
    115 !!gm      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    116 !!gm   END INTERFACE 
    117108   INTERFACE mpp_minloc 
    118109      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     
    477468    
    478469    
    479    !!    mpp_lnk_2d_e     utilisé dans ICB  
    480  
    481  
    482470   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    483471    
     
    485473   !!---------------------------------------------------------------------- 
    486474 
    487  
    488    SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    489       !!---------------------------------------------------------------------- 
    490       !!                  ***  routine mpp_lnk_2d_e  *** 
    491       !! 
    492       !! ** Purpose :   Message passing manadgement for 2d array (with halo) 
    493       !! 
    494       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    495       !!      between processors following neighboring subdomains. 
    496       !!            domain parameters 
    497       !!                    nlci   : first dimension of the local subdomain 
    498       !!                    nlcj   : second dimension of the local subdomain 
    499       !!                    jpri   : number of rows for extra outer halo 
    500       !!                    jprj   : number of columns for extra outer halo 
    501       !!                    nbondi : mark for "east-west local boundary" 
    502       !!                    nbondj : mark for "north-south local boundary" 
    503       !!                    noea   : number for local neighboring processors 
    504       !!                    nowe   : number for local neighboring processors 
    505       !!                    noso   : number for local neighboring processors 
    506       !!                    nono   : number for local neighboring processors 
    507       !! 
    508       !!---------------------------------------------------------------------- 
    509       INTEGER                                             , INTENT(in   ) ::   jpri 
    510       INTEGER                                             , INTENT(in   ) ::   jprj 
    511       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    512       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    513       !                                                                                 ! = T , U , V , F , W and I points 
    514       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the 
    515       !!                                                                                ! north boundary, =  1. otherwise 
    516       INTEGER  ::   jl   ! dummy loop indices 
    517       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    518       INTEGER  ::   ipreci, iprecj             ! temporary integers 
    519       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    520       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    521       !! 
    522       REAL(wp), DIMENSION(1-jpri:jpi+jpri,nn_hls+jprj,2) :: r2dns 
    523       REAL(wp), DIMENSION(1-jpri:jpi+jpri,nn_hls+jprj,2) :: r2dsn 
    524       REAL(wp), DIMENSION(1-jprj:jpj+jprj,nn_hls+jpri,2) :: r2dwe 
    525       REAL(wp), DIMENSION(1-jprj:jpj+jprj,nn_hls+jpri,2) :: r2dew 
    526       !!---------------------------------------------------------------------- 
    527  
    528       ipreci = nn_hls + jpri      ! take into account outer extra 2D overlap area 
    529       iprecj = nn_hls + jprj 
    530  
    531  
    532       ! 1. standard boundary treatment   (CAUTION: the order matters Here !!!! ) 
    533       ! ------------------------------ 
    534       !                                !== North-South boundaries 
    535       !                                      !* cyclic 
    536       IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    537          pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 
    538          pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj) 
    539       ELSE                                   !* closed 
    540          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  nn_hls  ) = 0._wp     ! south except at F-point 
    541                                       pt2d(:,nlcj-nn_hls+1:jpj+jprj) = 0._wp     ! north 
    542       ENDIF 
    543       !                                !== East-West boundaries 
    544       !                                      !* Cyclic east-west 
    545       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    546          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)              ! east 
    547          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)              ! west 
    548       ELSE                                   !* closed 
    549          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :nn_hls    ,:) = 0._wp  ! south except at F-point 
    550                                       pt2d(nlci-nn_hls+1:jpi+jpri,:) = 0._wp  ! north 
    551       ENDIF 
    552       ! 
    553       ! north fold treatment 
    554       ! -------------------- 
    555       IF( npolj /= 0 ) THEN 
    556          ! 
    557          SELECT CASE ( jpni ) 
    558 !!gm ERROR        CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    559                   CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    560          END SELECT 
    561          ! 
    562       ENDIF 
    563  
    564       ! 2. East and west directions exchange 
    565       ! ------------------------------------ 
    566       ! we play with the neigbours AND the row number because of the periodicity 
    567       ! 
    568       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    569       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    570          iihom = nlci-nreci-jpri 
    571          DO jl = 1, ipreci 
    572             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    573             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    574          END DO 
    575       END SELECT 
    576       ! 
    577       !                           ! Migrations 
    578       imigr = ipreci * ( jpj + 2*jprj) 
    579       ! 
    580       SELECT CASE ( nbondi ) 
    581       CASE ( -1 ) 
    582          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 
    583          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    584          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    585       CASE ( 0 ) 
    586          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    587          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 
    588          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    589          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    590          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    591          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    592       CASE ( 1 ) 
    593          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    594          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    595          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    596       END SELECT 
    597       ! 
    598       !                           ! Write Dirichlet lateral conditions 
    599       iihom = nlci - nn_hls 
    600       ! 
    601       SELECT CASE ( nbondi ) 
    602       CASE ( -1 ) 
    603          DO jl = 1, ipreci 
    604             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    605          END DO 
    606       CASE ( 0 ) 
    607          DO jl = 1, ipreci 
    608             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    609             pt2d( iihom+jl,:) = r2dew(:,jl,2) 
    610          END DO 
    611       CASE ( 1 ) 
    612          DO jl = 1, ipreci 
    613             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    614          END DO 
    615       END SELECT 
    616  
    617       ! 3. North and south directions 
    618       ! ----------------------------- 
    619       ! always closed : we play only with the neigbours 
    620       ! 
    621       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    622          ijhom = nlcj-nrecj-jprj 
    623          DO jl = 1, iprecj 
    624             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    625             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    626          END DO 
    627       ENDIF 
    628       ! 
    629       !                           ! Migrations 
    630       imigr = iprecj * ( jpi + 2*jpri ) 
    631       ! 
    632       SELECT CASE ( nbondj ) 
    633       CASE ( -1 ) 
    634          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 
    635          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    636          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    637       CASE ( 0 ) 
    638          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    639          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 
    640          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    641          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    642          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    643          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    644       CASE ( 1 ) 
    645          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    646          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    647          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    648       END SELECT 
    649       ! 
    650       !                           ! Write Dirichlet lateral conditions 
    651       ijhom = nlcj - nn_hls 
    652       ! 
    653       SELECT CASE ( nbondj ) 
    654       CASE ( -1 ) 
    655          DO jl = 1, iprecj 
    656             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    657          END DO 
    658       CASE ( 0 ) 
    659          DO jl = 1, iprecj 
    660             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    661             pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 
    662          END DO 
    663       CASE ( 1 ) 
    664          DO jl = 1, iprecj 
    665             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    666          END DO 
    667       END SELECT 
    668       ! 
    669    END SUBROUTINE mpp_lnk_2d_e 
    670475 
    671476 
     
    14431248 
    14441249 
    1445    SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    1446       !!--------------------------------------------------------------------- 
    1447       !!                   ***  routine mpp_lbc_north_2d  *** 
    1448       !! 
    1449       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1450       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1451       !!              array with outer extra halo 
    1452       !! 
    1453       !! ** Method  :   North fold condition and mpp with more than one proc 
    1454       !!              in i-direction require a specific treatment. We gather 
    1455       !!              the 4+2*jpr2dj northern lines of the global domain on 1 
    1456       !!              processor and apply lbc north-fold on this sub array. 
    1457       !!              Then we scatter the north fold array back to the processors. 
    1458       !! 
    1459       !!---------------------------------------------------------------------- 
    1460       REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1461       CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1462       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1463       ! 
    1464       INTEGER ::   ji, jj, jr 
    1465       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1466       INTEGER ::   ijpj, ij, iproc 
    1467       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1468       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1469       !!---------------------------------------------------------------------- 
    1470       ! 
    1471       ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    1472       ! 
    1473       ijpj=4 
    1474       ztab_e(:,:) = 0._wp 
    1475  
    1476       ij = 0 
    1477       ! put in znorthloc_e the last 4 jlines of pt2d 
    1478       DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    1479          ij = ij + 1 
    1480          DO ji = 1, jpi 
    1481             znorthloc_e(ji,ij) = pt2d(ji,jj) 
    1482          END DO 
    1483       END DO 
    1484       ! 
    1485       itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    1486       CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1487          &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    1488       ! 
    1489       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1490          iproc = nrank_north(jr) + 1 
    1491          ildi  = nldit (iproc) 
    1492          ilei  = nleit (iproc) 
    1493          iilb  = nimppt(iproc) 
    1494          DO jj = 1, ijpj+2*jpr2dj 
    1495             DO ji = ildi, ilei 
    1496                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1497             END DO 
    1498          END DO 
    1499       END DO 
    1500  
    1501       ! 2. North-Fold boundary conditions 
    1502       ! ---------------------------------- 
    1503 !!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    1504  
    1505       ij = jpr2dj 
    1506       !! Scatter back to pt2d 
    1507       DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj 
    1508       ij  = ij +1 
    1509          DO ji= 1, nlci 
    1510             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1511          END DO 
    1512       END DO 
    1513       ! 
    1514       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1515       ! 
    1516    END SUBROUTINE mpp_lbc_north_e 
    1517  
    1518  
    15191250   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 
    15201251      !!--------------------------------------------------------------------- 
     
    16081339 
    16091340 
    1610    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 
     1341   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, ipr2dj) 
    16111342      !!--------------------------------------------------------------------- 
    16121343      !!                   ***  routine mpp_lbc_north_icb  *** 
     
    16211352      !!              processor and apply lbc north-fold on this sub array. 
    16221353      !!              Then we scatter the north fold array back to the processors. 
    1623       !!              This version accounts for an extra halo with icebergs. 
     1354      !!              This routine accounts for an extra halo with icebergs 
     1355      !!              and assumes ghost rows and columns have been suppressed. 
    16241356      !! 
    16251357      !!---------------------------------------------------------------------- 
     
    16291361      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    16301362      !!                                                    ! north fold, =  1. otherwise 
    1631       INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj 
     1363      INTEGER                 , INTENT(in   ) ::   ipr2dj 
    16321364      ! 
    16331365      INTEGER ::   ji, jj, jr 
    16341366      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1635       INTEGER ::   ijpj, ij, iproc, ipr2dj 
     1367      INTEGER ::   ipj, ij, iproc 
    16361368      ! 
    16371369      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
     
    16391371      !!---------------------------------------------------------------------- 
    16401372      ! 
    1641       ijpj=4 
    1642       IF( PRESENT(pr2dj) ) THEN           ! use of additional halos 
    1643          ipr2dj = pr2dj 
    1644       ELSE 
    1645          ipr2dj = 0 
    1646       ENDIF 
    1647       ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 
    1648       ! 
    1649       ztab_e(:,:) = 0._wp 
     1373      ipj=4 
     1374      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpimax,4+2*ipr2dj), znorthgloio_e(jpimax,4+2*ipr2dj,jpni) ) 
     1375      ! 
     1376      ztab_e(:,:)      = 0._wp 
     1377      znorthloc_e(:,:) = 0._wp 
    16501378      ! 
    16511379      ij = 0 
    1652       ! put in znorthloc_e the last 4 jlines of pt2d 
    1653       DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 
     1380      ! put the last 4+2*ipr2dj lines of pt2d into znorthloc_e  
     1381      DO jj = jpj - ipj + 1 - ipr2dj, jpj +ipr2dj 
    16541382         ij = ij + 1 
    1655          DO ji = 1, jpi 
    1656             znorthloc_e(ji,ij)=pt2d(ji,jj) 
    1657          END DO 
     1383         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    16581384      END DO 
    16591385      ! 
    1660       itaille = jpi * ( ijpj + 2 * ipr2dj ) 
     1386      itaille = jpimax * ( ipj + 2 * ipr2dj ) 
    16611387      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
    16621388         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     
    16671393         ilei = nleit (iproc) 
    16681394         iilb = nimppt(iproc) 
    1669          DO jj = 1, ijpj+2*ipr2dj 
     1395         DO jj = 1, ipj+2*ipr2dj 
    16701396            DO ji = ildi, ilei 
    16711397               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
     
    16761402      ! 2. North-Fold boundary conditions 
    16771403      ! ---------------------------------- 
    1678 !!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
     1404      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, ipr2dj ) 
    16791405 
    16801406      ij = ipr2dj 
    16811407      !! Scatter back to pt2d 
    1682       DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 
     1408      DO jj = jpj - ipj + 1 , jpj +ipr2dj 
    16831409      ij  = ij +1 
    1684          DO ji= 1, nlci 
     1410         DO ji= 1, jpi 
    16851411            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    16861412         END DO 
     
    16961422      !!                  ***  routine mpp_lnk_2d_icb  *** 
    16971423      !! 
    1698       !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs) 
     1424      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     1425      !!                This routine receives a (1-jpri:jpi+jpri,1-jpri:jpj+jprj) 
     1426      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    16991427      !! 
    17001428      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    17011429      !!      between processors following neighboring subdomains. 
    17021430      !!            domain parameters 
    1703       !!                    nlci   : first dimension of the local subdomain 
    1704       !!                    nlcj   : second dimension of the local subdomain 
     1431      !!                    jpi    : first dimension of the local subdomain 
     1432      !!                    jpj    : second dimension of the local subdomain 
    17051433      !!                    jpri   : number of rows for extra outer halo 
    17061434      !!                    jprj   : number of columns for extra outer halo 
     
    17441472      ELSE                                        !* closed 
    17451473         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :nn_hls    ,:) = 0._wp    ! south except at F-point 
    1746                                       pt2d(nlci-nn_hls+1:jpi+jpri,:) = 0._wp    ! north 
     1474                                      pt2d(jpi-nn_hls+1:jpi+jpri,:) = 0._wp    ! north 
    17471475      ENDIF 
    17481476      ! 
     
    17531481         ! 
    17541482         SELECT CASE ( jpni ) 
    1755 !!gm ERROR         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1756                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
     1483                   CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, jprj ) 
     1484                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , jprj  ) 
    17571485         END SELECT 
    17581486         ! 
     
    17651493      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    17661494      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1767          iihom = nlci-nreci-jpri 
     1495         iihom = jpi-nreci-jpri 
    17681496         DO jl = 1, ipreci 
    17691497            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
     
    17941522      ! 
    17951523      !                           ! Write Dirichlet lateral conditions 
    1796       iihom = nlci - nn_hls 
     1524      iihom = jpi - nn_hls 
    17971525      ! 
    17981526      SELECT CASE ( nbondi ) 
     
    18181546      ! 
    18191547      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1820          ijhom = nlcj-nrecj-jprj 
     1548         ijhom = jpj-nrecj-jprj 
    18211549         DO jl = 1, iprecj 
    18221550            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
     
    18471575      ! 
    18481576      !                           ! Write Dirichlet lateral conditions 
    1849       ijhom = nlcj - nn_hls 
     1577      ijhom = jpj - nn_hls 
    18501578      ! 
    18511579      SELECT CASE ( nbondj ) 
Note: See TracChangeset for help on using the changeset viewer.