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 9012 – NEMO

Changeset 9012


Ignore:
Timestamp:
2017-12-13T14:57:33+01:00 (5 years ago)
Author:
acc
Message:

Branch dev_CNRS_2017. Merge in no_ghost changes from dev_r8126_ROBUST08_no_ghost. These changes include lib_mpp refresh and rationalisation of mppini from dev_r8126_ROBUST10_MPPINI

Location:
branches/2017/dev_CNRS_2017/NEMOGCM
Files:
1 added
1 deleted
22 edited

Legend:

Unmodified
Added
Removed

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r8882 r9012  
    2828      jpiglo  = nbcellsx + 2 + 2*nbghostcells 
    2929      jpjglo  = nbcellsy + 2 + 2*nbghostcells 
    30       jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    31       jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
     30      jpi     = ( jpiglo-2*nn_hls + (jpni-1+0) ) / jpni + 2*nn_hls 
     31      jpj     = ( jpjglo-2*nn_hls + (jpnj-1+0) ) / jpnj + 2*nn_hls 
    3232! JC: change to allow for different vertical levels 
    3333!     jpk is already set 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r8882 r9012  
    149149      !! ** Purpose :   initialization of the nemo model in off-line mode 
    150150      !!---------------------------------------------------------------------- 
    151       INTEGER ::   ji            ! dummy loop indices 
    152       INTEGER ::   ilocal_comm   ! local integer 
    153       INTEGER ::   ios, inum 
     151      INTEGER  ::   ji                 ! dummy loop indices 
     152      INTEGER  ::   ilocal_comm        ! local integer 
     153      INTEGER  ::   ios, inum          ! local integers 
     154      INTEGER  ::   iiarea, ijarea     ! local integers 
     155      INTEGER  ::   iirest, ijrest     ! local integers 
    154156      REAL(wp) ::   ziglo, zjglo, zkglo, zperio   ! local scalars 
    155157      CHARACTER(len=120), DIMENSION(30) ::   cltxt, cltxt2, clnam 
    … …  
    197199         CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
    198200      ENDIF 
    199       jpk    = jpkglo 
    200201      ! 
    201202      ! 
    … …  
    245246      END IF 
    246247 
    247       ! Calculate domain dimensions given calculated jpni and jpnj 
    248       ! This used to be done in par_oce.F90 when they were parameters rather 
    249       ! than variables 
    250       jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim. 
    251       jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
     248      iiarea = 1 + MOD( narea - 1 , jpni ) 
     249      ijarea = 1 + ( narea - 1 ) / jpni 
     250      iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni ) 
     251      ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj ) 
     252#if defined key_nemocice_decomp 
     253      jpi = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     254      jpj = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.  
     255      jpimax  = jpi 
     256      jpjmax  = jpj 
     257      IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls) 
     258      IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls) 
     259#else 
     260      jpi = ( jpiglo     -2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     261      jpj = ( jpjglo     -2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim. 
     262      jpimax  = jpi 
     263      jpjmax  = jpj 
     264      IF( iiarea > iirest ) jpi = jpi - 1 
     265      IF( ijarea > ijrest ) jpj = jpj - 1 
     266#endif 
     267 
     268      jpk   = jpkglo                                           ! third dim 
     269 
    252270      jpim1 = jpi-1                                            ! inner domain indices 
    253271      jpjm1 = jpj-1                                            !   "           " 
    254       jpkm1 = jpk-1                                            !   "           " 
     272      jpkm1 = MAX( 1, jpk-1 )                                  !   "           " 
    255273      jpij  = jpi*jpj                                          !  jpi x j 
    256274 
    … …  
    285303 
    286304      !                                      ! Domain decomposition 
    287       IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out 
    288       ELSE                            ;   CALL mpp_init2     ! eliminate land processors 
    289       ENDIF 
     305      CALL mpp_init 
    290306      ! 
    291307      IF( ln_timing    )   CALL timing_init 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r7646 r9012  
    18951895      jpjglo_crsm1 = jpjglo_crs - 1   
    18961896 
    1897       jpi_crs = ( jpiglo_crs   - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 
    1898       jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj    
     1897      jpi_crs = ( jpiglo_crs   - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls 
     1898      jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls    
    18991899               
    19001900      IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors   
    … …  
    19401940              CASE ( -1 ) 
    19411941                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nlejt_crs(jn) = nlejt_crs(jn) + 1 
    1942                 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 
     1942                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls 
    19431943                nldjt_crs(jn) = nldjt(jn) 
    19441944               
    … …  
    19471947                nldjt_crs(jn) = nldjt(jn) 
    19481948                IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1 
    1949                 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 
    1950                 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 
     1949                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls 
     1950                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls 
    19511951                 
    19521952              CASE ( 1, 2 ) 
    19531953               
    1954                 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 
     1954                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls 
    19551955                nlcjt_crs(jn) = nlejt_crs(jn) 
    19561956                nldjt_crs(jn) = nldjt(jn) 
    … …  
    19901990           SELECT CASE( ibonit(jn) ) 
    19911991              CASE ( -1 ) 
    1992                  nleit_crs(jn) = nleit_crs(jn) + jpreci            
    1993                  nlcit_crs(jn) = nleit_crs(jn) + jpreci 
     1992                 nleit_crs(jn) = nleit_crs(jn) + nn_hls            
     1993                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls 
    19941994                 nldit_crs(jn) = nldit(jn)  
    19951995               
    19961996              CASE ( 0 ) 
    1997                  nleit_crs(jn) = nleit_crs(jn) + jpreci 
    1998                  nlcit_crs(jn) = nleit_crs(jn) + jpreci 
     1997                 nleit_crs(jn) = nleit_crs(jn) + nn_hls 
     1998                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls 
    19991999                 nldit_crs(jn) = nldit(jn)  
    20002000                 
    20012001              CASE ( 1, 2 ) 
    20022002                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nleit_crs(jn) = nleit_crs(jn) + 1 
    2003                  nleit_crs(jn) = nleit_crs(jn) + jpreci 
     2003                 nleit_crs(jn) = nleit_crs(jn) + nn_hls 
    20042004                 nlcit_crs(jn) = nleit_crs(jn) 
    20052005                 nldit_crs(jn) = nldit(jn)  

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90

    r6140 r9012  
    133133       
    134134      tmask_i_crs(:,:) = tmask_crs(:,:,1) 
    135       iif = jpreci 
    136       iil = nlci_crs - jpreci + 1 
    137       ijf = jpreci 
    138       ijl = nlcj_crs - jprecj + 1 
     135      iif = nn_hls 
     136      iil = nlci_crs - nn_hls + 1 
     137      ijf = nn_hls 
     138      ijl = nlcj_crs - nn_hls + 1 
    139139      
    140140      tmask_i_crs( 1:iif ,    :  ) = 0._wp 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r8882 r9012  
    9090   INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    9191   INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions 
    92    INTEGER, PUBLIC ::   npne, npnw        !: index of north east and north west processor 
    93    INTEGER, PUBLIC ::   npse, npsw        !: index of south east and south west processor 
    94    INTEGER, PUBLIC ::   nbne, nbnw        !: logical of north east & north west processor 
    95    INTEGER, PUBLIC ::   nbse, nbsw        !: logical of south east & south west processor 
    9692   INTEGER, PUBLIC ::   nidom             !: ??? 
    9793 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r8970 r9012  
    9696         WRITE(numout,cform) '       ' ,'   jpij    : ', jpij 
    9797         WRITE(numout,*)     '      mpp local domain info (mpp):' 
    98          WRITE(numout,*)     '              jpni    : ', jpni, '   jpreci  : ', jpreci 
    99          WRITE(numout,*)     '              jpnj    : ', jpnj, '   jprecj  : ', jprecj 
     98         WRITE(numout,*)     '              jpni    : ', jpni, '   nn_hls  : ', nn_hls 
     99         WRITE(numout,*)     '              jpnj    : ', jpnj, '   nn_hls  : ', nn_hls 
    100100         WRITE(numout,*)     '              jpnij   : ', jpnij 
    101101         WRITE(numout,*)     '      lateral boundary of the Global domain : jperio  = ', jperio 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r8882 r9012  
    211211      ! -------------------- 
    212212      ! 
    213       iif = jpreci   ;   iil = nlci - jpreci + 1 
    214       ijf = jprecj   ;   ijl = nlcj - jprecj + 1 
     213      iif = nn_hls   ;   iil = nlci - nn_hls + 1 
     214      ijf = nn_hls   ;   ijl = nlcj - nn_hls + 1 
    215215      ! 
    216216      !                          ! halo mask : 0 on the halo and 1 elsewhere 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90

    r5025 r9012  
    441441 
    442442#if defined key_nemocice_decomp 
    443       ijpi = ( nx_global+2-2*jpreci + (isplt-1) ) / isplt + 2*jpreci 
    444       ijpj = ( ny_global+2-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj  
     443      ijpi = ( nx_global+2-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls 
     444      ijpj = ( ny_global+2-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls  
    445445#else 
    446       ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci 
    447       ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj 
     446      ijpi = ( jpiglo-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls 
     447      ijpj = ( jpjglo-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls 
    448448#endif 
    449449 
    450450 
    451       nrecil  = 2 * jpreci 
    452       nrecjl  = 2 * jprecj 
     451      nrecil  = 2 * nn_hls 
     452      nrecjl  = 2 * nn_hls 
    453453      irestil = MOD( jpiglo - nrecil , isplt ) 
    454454      irestjl = MOD( jpjglo - nrecjl , jsplt ) 
    … …  
    563563         ibonitl(jn) = nbondil 
    564564          
    565          nldil =  1   + jpreci 
    566          nleil = nlcil - jpreci 
     565         nldil =  1   + nn_hls 
     566         nleil = nlcil - nn_hls 
    567567         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1 
    568568         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil 
    569          nldjl =  1   + jprecj 
    570          nlejl = nlcjl - jprecj 
     569         nldjl =  1   + nn_hls 
     570         nlejl = nlcjl - nn_hls 
    571571         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1 
    572572         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbc_lnk_generic.h90

    r8882 r9012  
    33#   define SGN_IN(k)                psgn(k) 
    44#   define F_SIZE(ptab)             kfld 
     5#   define OPT_K(k)                 ,ipf 
    56#   if defined DIM_2d 
    67#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f) 
    … …  
    2627#   define SGN_IN(k)                psgn 
    2728#   define F_SIZE(ptab)             1 
     29#   define OPT_K(k)                  
    2830#   if defined DIM_2d 
    2931#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    … …  
    100102            ELSEIF( ll_nfd ) THEN                  !* north fold 
    101103               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point 
    102                CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) )                       ! north fold treatment          
     104               CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )                       ! north fold treatment          
    103105            ELSE                                   !* closed 
    104106               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point 
    … …  
    119121#undef L_SIZE 
    120122#undef F_SIZE 
     123#undef OPT_K 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbc_nfd_generic.h90

    r8882 r9012  
    4444#endif 
    4545 
     46#if defined MULTI 
    4647   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
     48      INTEGER          , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
     49#else 
     50   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn       ) 
     51#endif 
    4752      ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied 
    4853      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    4954      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    50       INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5155      ! 
    5256      INTEGER  ::    ji,  jj,  jk,  jl, jh,  jf   ! dummy loop indices 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r8882 r9012  
    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_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r8882 r9012  
    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_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r8882 r9012  
    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 
    … …  
    145136 
    146137   ! variables used in case of sea-ice 
    147    INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in icethd) 
     138   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 
    148139   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
    149140   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
    … …  
    454445#     include "mpp_bdy_generic.h90" 
    455446#     undef ROUTINE_BDY 
    456 #     define MULTI 
    457 #     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
    458 #     include "mpp_bdy_generic.h90" 
    459 #     undef ROUTINE_BDY 
    460 #     undef MULTI 
    461447#  undef DIM_2d 
    462448   ! 
    … …  
    467453#     include "mpp_bdy_generic.h90" 
    468454#     undef ROUTINE_BDY 
    469 #     define MULTI 
    470 #     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
    471 #     include "mpp_bdy_generic.h90" 
    472 #     undef ROUTINE_BDY 
    473 #     undef MULTI 
    474455#  undef DIM_3d 
    475456   ! 
    … …  
    480461!!#     include "mpp_bdy_generic.h90" 
    481462!!#     undef ROUTINE_BDY 
    482 !!#     define MULTI 
    483 !!#     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
    484 !!#     include "mpp_bdy_generic.h90" 
    485 !!#     undef ROUTINE_BDY 
    486 !!#     undef MULTI 
    487463!!#  undef DIM_4d 
    488464 
    … …  
    492468    
    493469    
    494    !!    mpp_lnk_2d_e     utilisé dans ICB  
    495  
    496  
    497470   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    498471    
    … …  
    500473   !!---------------------------------------------------------------------- 
    501474 
    502  
    503    SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    504       !!---------------------------------------------------------------------- 
    505       !!                  ***  routine mpp_lnk_2d_e  *** 
    506       !! 
    507       !! ** Purpose :   Message passing manadgement for 2d array (with halo) 
    508       !! 
    509       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    510       !!      between processors following neighboring subdomains. 
    511       !!            domain parameters 
    512       !!                    nlci   : first dimension of the local subdomain 
    513       !!                    nlcj   : second dimension of the local subdomain 
    514       !!                    jpri   : number of rows for extra outer halo 
    515       !!                    jprj   : number of columns for extra outer halo 
    516       !!                    nbondi : mark for "east-west local boundary" 
    517       !!                    nbondj : mark for "north-south local boundary" 
    518       !!                    noea   : number for local neighboring processors 
    519       !!                    nowe   : number for local neighboring processors 
    520       !!                    noso   : number for local neighboring processors 
    521       !!                    nono   : number for local neighboring processors 
    522       !! 
    523       !!---------------------------------------------------------------------- 
    524       INTEGER                                             , INTENT(in   ) ::   jpri 
    525       INTEGER                                             , INTENT(in   ) ::   jprj 
    526       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    527       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    528       !                                                                                 ! = T , U , V , F , W and I points 
    529       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the 
    530       !!                                                                                ! north boundary, =  1. otherwise 
    531       INTEGER  ::   jl   ! dummy loop indices 
    532       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    533       INTEGER  ::   ipreci, iprecj             ! temporary integers 
    534       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    535       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    536       !! 
    537       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    538       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    539       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    540       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 
    541       !!---------------------------------------------------------------------- 
    542  
    543       ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area 
    544       iprecj = jprecj + jprj 
    545  
    546  
    547       ! 1. standard boundary treatment   (CAUTION: the order matters Here !!!! ) 
    548       ! ------------------------------ 
    549       !                                !== North-South boundaries 
    550       !                                      !* cyclic 
    551       IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    552          pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 
    553          pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj) 
    554       ELSE                                   !* closed 
    555          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0._wp     ! south except at F-point 
    556                                       pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp     ! north 
    557       ENDIF 
    558       !                                !== East-West boundaries 
    559       !                                      !* Cyclic east-west 
    560       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    561          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)              ! east 
    562          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)              ! west 
    563       ELSE                                   !* closed 
    564          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp  ! south except at F-point 
    565                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp  ! north 
    566       ENDIF 
    567       ! 
    568       ! north fold treatment 
    569       ! -------------------- 
    570       IF( npolj /= 0 ) THEN 
    571          ! 
    572          SELECT CASE ( jpni ) 
    573 !!gm ERROR        CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    574 !!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    575          END SELECT 
    576          ! 
    577       ENDIF 
    578  
    579       ! 2. East and west directions exchange 
    580       ! ------------------------------------ 
    581       ! we play with the neigbours AND the row number because of the periodicity 
    582       ! 
    583       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    584       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    585          iihom = nlci-nreci-jpri 
    586          DO jl = 1, ipreci 
    587             r2dew(:,jl,1) = pt2d(jpreci+jl,:) 
    588             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    589          END DO 
    590       END SELECT 
    591       ! 
    592       !                           ! Migrations 
    593       imigr = ipreci * ( jpj + 2*jprj) 
    594       ! 
    595       SELECT CASE ( nbondi ) 
    596       CASE ( -1 ) 
    597          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 
    598          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    599          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    600       CASE ( 0 ) 
    601          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    602          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 
    603          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    604          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    605          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    606          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    607       CASE ( 1 ) 
    608          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    609          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    610          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    611       END SELECT 
    612       ! 
    613       !                           ! Write Dirichlet lateral conditions 
    614       iihom = nlci - jpreci 
    615       ! 
    616       SELECT CASE ( nbondi ) 
    617       CASE ( -1 ) 
    618          DO jl = 1, ipreci 
    619             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    620          END DO 
    621       CASE ( 0 ) 
    622          DO jl = 1, ipreci 
    623             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    624             pt2d( iihom+jl,:) = r2dew(:,jl,2) 
    625          END DO 
    626       CASE ( 1 ) 
    627          DO jl = 1, ipreci 
    628             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    629          END DO 
    630       END SELECT 
    631  
    632       ! 3. North and south directions 
    633       ! ----------------------------- 
    634       ! always closed : we play only with the neigbours 
    635       ! 
    636       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    637          ijhom = nlcj-nrecj-jprj 
    638          DO jl = 1, iprecj 
    639             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    640             r2dns(:,jl,1) = pt2d(:,jprecj+jl) 
    641          END DO 
    642       ENDIF 
    643       ! 
    644       !                           ! Migrations 
    645       imigr = iprecj * ( jpi + 2*jpri ) 
    646       ! 
    647       SELECT CASE ( nbondj ) 
    648       CASE ( -1 ) 
    649          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 
    650          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    651          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    652       CASE ( 0 ) 
    653          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    654          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 
    655          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    656          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    657          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    658          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    659       CASE ( 1 ) 
    660          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    661          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    662          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    663       END SELECT 
    664       ! 
    665       !                           ! Write Dirichlet lateral conditions 
    666       ijhom = nlcj - jprecj 
    667       ! 
    668       SELECT CASE ( nbondj ) 
    669       CASE ( -1 ) 
    670          DO jl = 1, iprecj 
    671             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    672          END DO 
    673       CASE ( 0 ) 
    674          DO jl = 1, iprecj 
    675             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    676             pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 
    677          END DO 
    678       CASE ( 1 ) 
    679          DO jl = 1, iprecj 
    680             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    681          END DO 
    682       END SELECT 
    683       ! 
    684    END SUBROUTINE mpp_lnk_2d_e 
    685475 
    686476 
    … …  
    14581248 
    14591249 
    1460    SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    1461       !!--------------------------------------------------------------------- 
    1462       !!                   ***  routine mpp_lbc_north_2d  *** 
    1463       !! 
    1464       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1465       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1466       !!              array with outer extra halo 
    1467       !! 
    1468       !! ** Method  :   North fold condition and mpp with more than one proc 
    1469       !!              in i-direction require a specific treatment. We gather 
    1470       !!              the 4+2*jpr2dj northern lines of the global domain on 1 
    1471       !!              processor and apply lbc north-fold on this sub array. 
    1472       !!              Then we scatter the north fold array back to the processors. 
    1473       !! 
    1474       !!---------------------------------------------------------------------- 
    1475       REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1476       CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1477       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1478       ! 
    1479       INTEGER ::   ji, jj, jr 
    1480       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1481       INTEGER ::   ijpj, ij, iproc 
    1482       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1483       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1484       !!---------------------------------------------------------------------- 
    1485       ! 
    1486       ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    1487       ! 
    1488       ijpj=4 
    1489       ztab_e(:,:) = 0._wp 
    1490  
    1491       ij = 0 
    1492       ! put in znorthloc_e the last 4 jlines of pt2d 
    1493       DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    1494          ij = ij + 1 
    1495          DO ji = 1, jpi 
    1496             znorthloc_e(ji,ij) = pt2d(ji,jj) 
    1497          END DO 
    1498       END DO 
    1499       ! 
    1500       itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    1501       CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1502          &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    1503       ! 
    1504       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1505          iproc = nrank_north(jr) + 1 
    1506          ildi  = nldit (iproc) 
    1507          ilei  = nleit (iproc) 
    1508          iilb  = nimppt(iproc) 
    1509          DO jj = 1, ijpj+2*jpr2dj 
    1510             DO ji = ildi, ilei 
    1511                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1512             END DO 
    1513          END DO 
    1514       END DO 
    1515  
    1516       ! 2. North-Fold boundary conditions 
    1517       ! ---------------------------------- 
    1518 !!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    1519  
    1520       ij = jpr2dj 
    1521       !! Scatter back to pt2d 
    1522       DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj 
    1523       ij  = ij +1 
    1524          DO ji= 1, nlci 
    1525             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1526          END DO 
    1527       END DO 
    1528       ! 
    1529       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1530       ! 
    1531    END SUBROUTINE mpp_lbc_north_e 
    1532  
    1533  
    15341250   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 
    15351251      !!--------------------------------------------------------------------- 
    … …  
    16231339 
    16241340 
    1625    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 
     1341   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    16261342      !!--------------------------------------------------------------------- 
    16271343      !!                   ***  routine mpp_lbc_north_icb  *** 
    … …  
    16331349      !! ** Method  :   North fold condition and mpp with more than one proc 
    16341350      !!              in i-direction require a specific treatment. We gather 
    1635       !!              the 4+2*jpr2dj northern lines of the global domain on 1 
     1351      !!              the 4+kextj northern lines of the global domain on 1 
    16361352      !!              processor and apply lbc north-fold on this sub array. 
    16371353      !!              Then we scatter the north fold array back to the processors. 
    1638       !!              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. 
    16391356      !! 
    16401357      !!---------------------------------------------------------------------- 
    … …  
    16441361      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    16451362      !!                                                    ! north fold, =  1. otherwise 
    1646       INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj 
     1363      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    16471364      ! 
    16481365      INTEGER ::   ji, jj, jr 
    16491366      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1650       INTEGER ::   ijpj, ij, iproc, ipr2dj 
     1367      INTEGER ::   ipj, ij, iproc 
    16511368      ! 
    16521369      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    … …  
    16541371      !!---------------------------------------------------------------------- 
    16551372      ! 
    1656       ijpj=4 
    1657       IF( PRESENT(pr2dj) ) THEN           ! use of additional halos 
    1658          ipr2dj = pr2dj 
    1659       ELSE 
    1660          ipr2dj = 0 
    1661       ENDIF 
    1662       ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 
    1663       ! 
    1664       ztab_e(:,:) = 0._wp 
     1373      ipj=4 
     1374      ALLOCATE( ztab_e(jpiglo,ipj+kextj), znorthloc_e(  jpimax,ipj+kextj), & 
     1375     &                                    znorthgloio_e(jpimax,ipj+kextj,jpni) ) 
     1376      ! 
     1377      ztab_e(:,:)      = 0._wp 
     1378      znorthloc_e(:,:) = 0._wp 
    16651379      ! 
    16661380      ij = 0 
    1667       ! put in znorthloc_e the last 4 jlines of pt2d 
    1668       DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 
     1381      ! put the last ipj+kextj lines of pt2d into znorthloc_e  
     1382      DO jj = jpj - ipj + 1, jpj + kextj 
    16691383         ij = ij + 1 
    1670          DO ji = 1, jpi 
    1671             znorthloc_e(ji,ij)=pt2d(ji,jj) 
    1672          END DO 
     1384         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    16731385      END DO 
    16741386      ! 
    1675       itaille = jpi * ( ijpj + 2 * ipr2dj ) 
     1387      itaille = jpimax * ( ipj + kextj ) 
    16761388      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
    16771389         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    … …  
    16821394         ilei = nleit (iproc) 
    16831395         iilb = nimppt(iproc) 
    1684          DO jj = 1, ijpj+2*ipr2dj 
     1396         DO jj = 1, ipj+kextj 
    16851397            DO ji = ildi, ilei 
    16861398               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    … …  
    16911403      ! 2. North-Fold boundary conditions 
    16921404      ! ---------------------------------- 
    1693 !!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    1694  
    1695       ij = ipr2dj 
     1405      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, kextj ) 
     1406 
     1407      ij = 0 
    16961408      !! Scatter back to pt2d 
    1697       DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 
     1409      DO jj = jpj - ipj + 1 , jpj + kextj 
    16981410      ij  = ij +1 
    1699          DO ji= 1, nlci 
     1411         DO ji= 1, jpi 
    17001412            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    17011413         END DO 
    … …  
    17071419 
    17081420 
    1709    SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 
     1421   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj ) 
    17101422      !!---------------------------------------------------------------------- 
    17111423      !!                  ***  routine mpp_lnk_2d_icb  *** 
    17121424      !! 
    1713       !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs) 
     1425      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     1426      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
     1427      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    17141428      !! 
    17151429      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    17161430      !!      between processors following neighboring subdomains. 
    17171431      !!            domain parameters 
    1718       !!                    nlci   : first dimension of the local subdomain 
    1719       !!                    nlcj   : second dimension of the local subdomain 
    1720       !!                    jpri   : number of rows for extra outer halo 
    1721       !!                    jprj   : number of columns for extra outer halo 
     1432      !!                    jpi    : first dimension of the local subdomain 
     1433      !!                    jpj    : second dimension of the local subdomain 
     1434      !!                    kexti  : number of columns for extra outer halo 
     1435      !!                    kextj  : number of rows for extra outer halo 
    17221436      !!                    nbondi : mark for "east-west local boundary" 
    17231437      !!                    nbondj : mark for "north-south local boundary" 
    … …  
    17271441      !!                    nono   : number for local neighboring processors 
    17281442      !!---------------------------------------------------------------------- 
    1729       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1730       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1731       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1732       INTEGER                                             , INTENT(in   ) ::   jpri 
    1733       INTEGER                                             , INTENT(in   ) ::   jprj 
     1443      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     1444      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     1445      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     1446      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
     1447      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    17341448      ! 
    17351449      INTEGER  ::   jl   ! dummy loop indices 
    … …  
    17391453      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    17401454      !! 
    1741       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) ::   r2dns, r2dsn 
    1742       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) ::   r2dwe, r2dew 
    1743       !!---------------------------------------------------------------------- 
    1744  
    1745       ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area 
    1746       iprecj = jprecj + jprj 
     1455      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
     1456      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
     1457      !!---------------------------------------------------------------------- 
     1458 
     1459      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
     1460      iprecj = nn_hls + kextj 
    17471461 
    17481462 
    … …  
    17541468      !                                           !* Cyclic east-west 
    17551469      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1756          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east 
    1757          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west 
     1470         pt2d(1-kexti:     1    ,:) = pt2d(jpim1-kexti:  jpim1 ,:)       ! east 
     1471         pt2d(   jpi  :jpi+kexti,:) = pt2d(     2      :2+kexti,:)       ! west 
    17581472         ! 
    17591473      ELSE                                        !* closed 
    1760          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point 
    1761                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north 
     1474         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls    ,:) = 0._wp    ! south except at F-point 
     1475                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! north 
    17621476      ENDIF 
    17631477      ! 
    … …  
    17681482         ! 
    17691483         SELECT CASE ( jpni ) 
    1770 !!gm ERROR         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1771 !!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj ) 
     1484                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     1485                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    17721486         END SELECT 
    17731487         ! 
    … …  
    17801494      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    17811495      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1782          iihom = nlci-nreci-jpri 
     1496         iihom = jpi-nreci-kexti 
    17831497         DO jl = 1, ipreci 
    1784             r2dew(:,jl,1) = pt2d(jpreci+jl,:) 
     1498            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    17851499            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    17861500         END DO 
    … …  
    17881502      ! 
    17891503      !                           ! Migrations 
    1790       imigr = ipreci * ( jpj + 2*jprj) 
     1504      imigr = ipreci * ( jpj + 2*kextj ) 
    17911505      ! 
    17921506      SELECT CASE ( nbondi ) 
    17931507      CASE ( -1 ) 
    1794          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 
    1795          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
     1508         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
     1509         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    17961510         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    17971511      CASE ( 0 ) 
    1798          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    1799          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 
    1800          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    1801          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
     1512         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     1513         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
     1514         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     1515         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    18021516         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    18031517         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    18041518      CASE ( 1 ) 
    1805          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    1806          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
     1519         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     1520         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    18071521         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    18081522      END SELECT 
    18091523      ! 
    18101524      !                           ! Write Dirichlet lateral conditions 
    1811       iihom = nlci - jpreci 
     1525      iihom = jpi - nn_hls 
    18121526      ! 
    18131527      SELECT CASE ( nbondi ) 
    … …  
    18181532      CASE ( 0 ) 
    18191533         DO jl = 1, ipreci 
    1820             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    1821             pt2d( iihom+jl,:) = r2dew(:,jl,2) 
     1534            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     1535            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    18221536         END DO 
    18231537      CASE ( 1 ) 
    18241538         DO jl = 1, ipreci 
    1825             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
     1539            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    18261540         END DO 
    18271541      END SELECT 
    … …  
    18331547      ! 
    18341548      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1835          ijhom = nlcj-nrecj-jprj 
     1549         ijhom = jpj-nrecj-kextj 
    18361550         DO jl = 1, iprecj 
    18371551            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1838             r2dns(:,jl,1) = pt2d(:,jprecj+jl) 
     1552            r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    18391553         END DO 
    18401554      ENDIF 
    18411555      ! 
    18421556      !                           ! Migrations 
    1843       imigr = iprecj * ( jpi + 2*jpri ) 
     1557      imigr = iprecj * ( jpi + 2*kexti ) 
    18441558      ! 
    18451559      SELECT CASE ( nbondj ) 
    18461560      CASE ( -1 ) 
    1847          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 
    1848          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
     1561         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
     1562         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    18491563         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    18501564      CASE ( 0 ) 
    1851          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    1852          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 
    1853          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    1854          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
     1565         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     1566         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
     1567         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     1568         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    18551569         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    18561570         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    18571571      CASE ( 1 ) 
    1858          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    1859          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
     1572         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     1573         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    18601574         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    18611575      END SELECT 
    18621576      ! 
    18631577      !                           ! Write Dirichlet lateral conditions 
    1864       ijhom = nlcj - jprecj 
     1578      ijhom = jpj - nn_hls 
    18651579      ! 
    18661580      SELECT CASE ( nbondj ) 
    … …  
    18711585      CASE ( 0 ) 
    18721586         DO jl = 1, iprecj 
    1873             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    1874             pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 
     1587            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     1588            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    18751589         END DO 
    18761590      CASE ( 1 ) 
    18771591         DO jl = 1, iprecj 
    1878             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
     1592            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    18791593         END DO 
    18801594      END SELECT 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_bdy_generic.h90

    r8882 r9012  
    1 #if defined MULTI 
    2 #   define NAT_IN(k)                cd_nat(k)    
    3 #   define SGN_IN(k)                psgn(k) 
    4 #   define IBD_IN(k)                kb_bdy(k) 
    5 #   define F_SIZE(ptab)             kfld 
    6 #   if defined DIM_2d 
    7 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f) 
    8 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    9 #      define K_SIZE(ptab)             1 
    10 #      define L_SIZE(ptab)             1 
    11 #   endif 
    12 #   if defined DIM_3d 
    13 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f) 
    14 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    15 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    16 #      define L_SIZE(ptab)             1 
    17 #   endif 
    18 #   if defined DIM_4d 
    19 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f) 
    20 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    21 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    22 #      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    23 #   endif 
    24 #else 
    251#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
    262#   define NAT_IN(k)                cd_nat 
    … …  
    284#   define IBD_IN(k)                kb_bdy 
    295#   define F_SIZE(ptab)             1 
     6#   define OPT_K(k)                  
    307#   if defined DIM_2d 
    318#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    … …  
    4320#      define L_SIZE(ptab)          SIZE(ptab,4) 
    4421#   endif 
    45 #endif 
    46  
    47 #if defined MULTI 
    48    SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn, kfld, kb_bdy ) 
    49       INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    50 #else 
     22 
    5123   SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn      , kb_bdy ) 
    52 #endif 
    5324      !!---------------------------------------------------------------------- 
    5425      !!                  ***  routine mpp_lnk_bdy_3d  *** 
    … …  
    9162      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    9263      !       
    93       ALLOCATE( zt3ns(jpi,jprecj,ipk,ipl,ipf,2), zt3sn(jpi,jprecj,ipk,ipl,ipf,2),   & 
    94          &      zt3ew(jpj,jpreci,ipk,ipl,ipf,2), zt3we(jpj,jpreci,ipk,ipl,ipf,2)  ) 
     64      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   & 
     65         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  ) 
    9566 
    9667      zland = 0._wp 
    … …  
    10980               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf) 
    11081            ELSE                                   !* Closed 
    111                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :jpreci,:,:,:,jf) = zland  ! east except F-point 
    112                                                ARRAY_IN(nlci-jpreci+1:jpi   ,:,:,:,jf) = zland  ! west 
     82               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland  ! east except F-point 
     83                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland  ! west 
    11384            ENDIF 
    11485         ELSEIF(nbondi == -1) THEN              ! subdomain to the east only 
    115             IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(1:jpreci,:,:,:,jf) = zland     ! south except F-point 
     86            IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(1:nn_hls,:,:,:,jf) = zland     ! south except F-point 
    11687            ! 
    11788         ELSEIF(nbondi == 1) THEN               ! subdomain to the west only 
    118             ARRAY_IN(nlci-jpreci+1:jpi,:,:,:,jf) = zland    ! north 
     89            ARRAY_IN(nlci-nn_hls+1:jpi,:,:,:,jf) = zland    ! north 
    11990         ENDIF 
    12091         !                                ! North-South boundaries 
    12192         ! 
    12293         IF (nbondj == 2 .OR. nbondj == -1) THEN      !* closed 
    123            IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,1:jprecj,:,:,jf) = zland            ! south except F-point 
     94           IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,1:nn_hls,:,:,jf) = zland            ! south except F-point 
    12495         ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    125                                            ARRAY_IN(:,nlcj-jprecj+1:jpj,:,:,jf) = zland   ! north 
     96                                           ARRAY_IN(:,nlcj-nn_hls+1:jpj,:,:,jf) = zland   ! north 
    12697         ENDIF 
    12798      END DO 
    … …  
    138109               DO jl = 1, ipl 
    139110                  DO jk = 1, ipk 
    140                      DO jh = 1, jpreci 
    141                         zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(jpreci+jh,:,jk,jl,jf) 
     111                     DO jh = 1, nn_hls 
     112                        zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    142113                        zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    143114                     END DO 
    … …  
    147118         ! 
    148119         !                           ! Migrations 
    149 !!gm      imigr = jpreci * jpj * ipk * ipl * ipf 
    150          imigr = jpreci * jpj * ipk * ipl 
     120!!gm      imigr = nn_hls * jpj * ipk * ipl * ipf 
     121         imigr = nn_hls * jpj * ipk * ipl 
    151122         ! 
    152123         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) 
    … …  
    169140         ! 
    170141         !                           ! Write Dirichlet lateral conditions 
    171          iihom = nlci-jpreci 
     142         iihom = nlci-nn_hls 
    172143         ! 
    173144         ! 
    … …  
    176147            DO jl = 1, ipl 
    177148               DO jk = 1, ipk 
    178                   DO jh = 1, jpreci 
     149                  DO jh = 1, nn_hls 
    179150                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    180151                  END DO 
    … …  
    184155            DO jl = 1, ipl 
    185156               DO jk = 1, ipk 
    186                   DO jh = 1, jpreci 
     157                  DO jh = 1, nn_hls 
    187158                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    188159                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    … …  
    193164            DO jl = 1, ipl 
    194165               DO jk = 1, ipk 
    195                   DO jh = 1, jpreci 
     166                  DO jh = 1, nn_hls 
    196167                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    197168                  END DO 
    … …  
    211182            DO jl = 1, ipl 
    212183               DO jk = 1, ipk 
    213                   DO jh = 1, jprecj 
     184                  DO jh = 1, nn_hls 
    214185                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    215                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,jprecj+jh,jk,jl,jf) 
     186                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    216187                  END DO 
    217188               END DO 
    … …  
    220191         ! 
    221192         !                           ! Migrations 
    222 !!gm      imigr = jprecj * jpi * ipk * ipl * ipf 
    223          imigr = jprecj * jpi * ipk * ipl 
     193!!gm      imigr = nn_hls * jpi * ipk * ipl * ipf 
     194         imigr = nn_hls * jpi * ipk * ipl 
    224195         ! 
    225196         SELECT CASE ( nbondj_bdy(IBD_IN(jf)) ) 
    … …  
    242213         ! 
    243214         !                           ! Write Dirichlet lateral conditions 
    244          ijhom = nlcj-jprecj 
     215         ijhom = nlcj-nn_hls 
    245216         ! 
    246217         SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) ) 
    … …  
    248219            DO jl = 1, ipl 
    249220               DO jk = 1, ipk 
    250                   DO jh = 1, jprecj 
     221                  DO jh = 1, nn_hls 
    251222                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    252223                  END DO 
    … …  
    256227            DO jl = 1, ipl 
    257228               DO jk = 1, ipk 
    258                   DO jh = 1, jprecj 
     229                  DO jh = 1, nn_hls 
    259230                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    260231                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    … …  
    265236            DO jl = 1, ipl 
    266237               DO jk = 1, ipk 
    267                   DO jh = 1, jprecj 
     238                  DO jh = 1, nn_hls 
    268239                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    269240                  END DO 
    … …  
    279250         ! 
    280251         SELECT CASE ( jpni ) 
    281          CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) )   ! only 1 northern proc, no mpp 
    282          CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) )   ! for all northern procs. 
     252         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp 
     253         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs. 
    283254         END SELECT 
    284255         ! 
    … …  
    297268#undef L_SIZE 
    298269#undef F_SIZE 
     270#undef OPT_K 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_lnk_generic.h90

    r8882 r9012  
    7272      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7373      ! 
    74       ALLOCATE( zt3ns(jpi,jprecj,ipk,ipl,ipf,2), zt3sn(jpi,jprecj,ipk,ipl,ipf,2),   & 
    75          &      zt3ew(jpj,jpreci,ipk,ipl,ipf,2), zt3we(jpj,jpreci,ipk,ipl,ipf,2)  ) 
     74      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   & 
     75         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  ) 
    7676      ! 
    7777      ll_Iperio = nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) 
    … …  
    116116               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf) 
    117117            ELSE                                   !* closed 
    118                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :jpreci,:,:,:,jf) = zland    ! east except F-point 
    119                                                ARRAY_IN(nlci-jpreci+1:jpi   ,:,:,:,jf) = zland    ! west 
     118               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point 
     119                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west 
    120120            ENDIF 
    121121            !                                ! North-South boundaries 
    … …  
    124124               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf) 
    125125            ELSE                                   !* closed 
    126                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :jprecj,:,:,jf) = zland    ! south except F-point 
    127                                                ARRAY_IN(:,nlcj-jprecj+1:jpj   ,:,:,jf) = zland    ! north 
     126               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point 
     127                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north 
    128128            ENDIF 
    129129         END DO 
    … …  
    142142            DO jl = 1, ipl 
    143143               DO jk = 1, ipk 
    144                   DO jh = 1, jpreci 
    145                      zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(jpreci+jh,:,jk,jl,jf) 
     144                  DO jh = 1, nn_hls 
     145                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    146146                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    147147                  END DO 
    … …  
    152152      ! 
    153153      !                           ! Migrations 
    154       imigr = jpreci * jpj * ipk * ipl * ipf 
     154      imigr = nn_hls * jpj * ipk * ipl * ipf 
    155155      ! 
    156156      SELECT CASE ( nbondi ) 
    … …  
    173173      ! 
    174174      !                           ! Write Dirichlet lateral conditions 
    175       iihom = nlci-jpreci 
     175      iihom = nlci-nn_hls 
    176176      ! 
    177177      SELECT CASE ( nbondi ) 
    … …  
    180180            DO jl = 1, ipl 
    181181               DO jk = 1, ipk 
    182                   DO jh = 1, jpreci 
     182                  DO jh = 1, nn_hls 
    183183                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    184184                  END DO 
    … …  
    190190            DO jl = 1, ipl 
    191191               DO jk = 1, ipk 
    192                   DO jh = 1, jpreci 
     192                  DO jh = 1, nn_hls 
    193193                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    194194                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    … …  
    201201            DO jl = 1, ipl 
    202202               DO jk = 1, ipk 
    203                   DO jh = 1, jpreci 
     203                  DO jh = 1, nn_hls 
    204204                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    205205                  END DO 
    … …  
    218218            DO jl = 1, ipl 
    219219               DO jk = 1, ipk 
    220                   DO jh = 1, jprecj 
     220                  DO jh = 1, nn_hls 
    221221                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    222                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,jprecj+jh,jk,jl,jf) 
     222                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    223223                  END DO 
    224224               END DO 
    … …  
    228228      ! 
    229229      !                           ! Migrations 
    230       imigr = jprecj * jpi * ipk * ipl * ipf 
     230      imigr = nn_hls * jpi * ipk * ipl * ipf 
    231231      ! 
    232232      SELECT CASE ( nbondj ) 
    … …  
    249249      ! 
    250250      !                           ! Write Dirichlet lateral conditions 
    251       ijhom = nlcj-jprecj 
     251      ijhom = nlcj-nn_hls 
    252252      ! 
    253253      SELECT CASE ( nbondj ) 
    … …  
    256256            DO jl = 1, ipl 
    257257               DO jk = 1, ipk 
    258                   DO jh = 1, jprecj 
     258                  DO jh = 1, nn_hls 
    259259                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    260260                  END DO 
    … …  
    266266            DO jl = 1, ipl 
    267267               DO jk = 1, ipk 
    268                   DO jh = 1, jprecj 
     268                  DO jh = 1, nn_hls 
    269269                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    270270                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    … …  
    277277            DO jl = 1, ipl 
    278278               DO jk = 1, ipk 
    279                   DO jh = 1, jprecj 
     279                  DO jh = 1, nn_hls 
    280280                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    281281                  END DO 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_nfd_generic.h90

    r8882 r9012  
    7373      ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 
    7474      ! 
    75       ALLOCATE( znorthloc(jpi,4,ipk,ipl,ipf) ) 
     75      ALLOCATE( znorthloc(jpimax,4,ipk,ipl,ipf) ) 
    7676      ! 
    7777      znorthloc(:,:,:,:,:) = 0._wp 
    … …  
    8282               DO jj = nlcj - ipj +1, nlcj 
    8383                  ij = jj - nlcj + ipj 
    84                   znorthloc(:,ij,jk,jl,jf) = ARRAY_IN(:,jj,jk,jl,jf) 
     84                  znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 
    8585               END DO 
    8686            END DO 
    … …  
    8989      ! 
    9090      ! 
    91       itaille = jpi * ipj * ipk * ipl * ipf 
     91      itaille = jpimax * ipj * ipk * ipl * ipf 
    9292      ! 
    9393      IF( l_north_nogather ) THEN      !==  ????  ==! 
    … …  
    177177      ELSE                             !==  ????  ==! 
    178178         ALLOCATE( ztab       (jpiglo,4,ipk,ipl,ipf     ) ) 
    179          ALLOCATE( znorthgloio(jpi   ,4,ipk,ipl,ipf,jpni) ) 
     179         ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) ) 
    180180         ! 
    181181         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    … …  
    222222      ENDIF 
    223223      ! 
    224       ! The ztab array has been either: 
    225       !  a. Fully populated by the mpi_allgather operation or 
    226       !  b. Had the active points for this domain and northern neighbours populated 
    227       !     by peer to peer exchanges 
    228       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    229       ! this domain will be identical. 
    230       ! 
    231224      DEALLOCATE( znorthloc ) 
    232225      ! 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r7646 r9012  
    11MODULE mppini 
    2    !!============================================================================== 
     2   !!====================================================================== 
    33   !!                       ***  MODULE mppini   *** 
    44   !! Ocean initialization : distributed memory computing initialization 
    5    !!============================================================================== 
    6  
    7    !!---------------------------------------------------------------------- 
    8    !!   mpp_init       : Lay out the global domain over processors 
    9    !!   mpp_init2      : Lay out the global domain over processors  
    10    !!                    with land processor elimination 
    11    !!   mpp_init_ioispl: IOIPSL initialization in mpp 
    12    !!---------------------------------------------------------------------- 
    13    USE dom_oce         ! ocean space and time domain  
    14    USE in_out_manager  ! I/O Manager 
    15    USE lib_mpp         ! distribued memory computing library 
    16    USE ioipsl 
     5   !!====================================================================== 
     6   !! History :  6.0  !  1994-11  (M. Guyon)  Original code 
     7   !!  OPA       7.0  !  1995-04  (J. Escobar, M. Imbard) 
     8   !!            8.0  !  1998-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions 
     9   !!  NEMO      1.0  !  2004-01  (G. Madec, J.M Molines)  F90 : free form , north fold jpni > 1 
     10   !!            4.0  !  2016-06  (G. Madec)  use domain configuration file instead of bathymetry file 
     11   !!            4.0  !  2017-06  (J.M. Molines, T. Lovato) merge of mppini and mppini_2 
     12   !!---------------------------------------------------------------------- 
     13 
     14   !!---------------------------------------------------------------------- 
     15   !!  mpp_init       : Lay out the global domain over processors with/without land processor elimination 
     16   !!  mpp_init_mask  :  
     17   !!  mpp_init_ioipsl: IOIPSL initialization in mpp  
     18   !!---------------------------------------------------------------------- 
     19   USE dom_oce        ! ocean space and time domain 
     20   USE bdy_oce        ! open BounDarY   
     21   ! 
     22   USE lib_mpp        ! distribued memory computing library 
     23   USE iom            ! nemo I/O library  
     24   USE ioipsl         ! I/O IPSL library 
     25   USE in_out_manager ! I/O Manager 
    1726 
    1827   IMPLICIT NONE 
    … …  
    2029 
    2130   PUBLIC mpp_init       ! called by opa.F90 
    22    PUBLIC mpp_init2      ! called by opa.F90 
    23  
    24    !!---------------------------------------------------------------------- 
    25    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     31 
     32   !!---------------------------------------------------------------------- 
     33   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    2634   !! $Id$  
    2735   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4149      !! 
    4250      !! ** Method  :   Shared memory computing, set the local processor 
    43       !!      variables to the value of the global domain 
    44       !! 
    45       !! History : 
    46       !!   9.0  !  04-01  (G. Madec, J.M. Molines)  F90 : free form, north fold jpni >1 
    47       !!---------------------------------------------------------------------- 
    48  
    49       ! No mpp computation 
    50       nimpp  = 1 
     51      !!              variables to the value of the global domain 
     52      !!---------------------------------------------------------------------- 
     53      ! 
     54      nimpp  = 1           !  
    5155      njmpp  = 1 
    5256      nlci   = jpi 
    … …  
    6165      nidom  = FLIO_DOM_NONE 
    6266      npolj = jperio 
    63  
     67      ! 
    6468      IF(lwp) THEN 
    6569         WRITE(numout,*) 
    66          WRITE(numout,*) 'mpp_init(2) : NO massively parallel processing' 
    67          WRITE(numout,*) '~~~~~~~~~~~ ' 
    68          WRITE(numout,*) '         nperio = ', nperio 
    69          WRITE(numout,*) '         npolj  = ', npolj 
    70          WRITE(numout,*) '         nimpp  = ', nimpp 
    71          WRITE(numout,*) '         njmpp  = ', njmpp 
    72       ENDIF 
    73  
    74       IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) & 
    75           CALL ctl_stop( 'equality  jpni = jpnj = jpnij = 1 is not satisfied',   & 
    76           &              'the domain is lay out for distributed memory computing! ' ) 
    77  
    78       IF( jperio == 7 ) CALL ctl_stop( ' jperio = 7 needs distributed memory computing ',   & 
    79           &              ' with 1 process. Add key_mpp_mpi in the list of active cpp keys ' ) 
     70         WRITE(numout,*) 'mpp_init : NO massively parallel processing' 
     71         WRITE(numout,*) '~~~~~~~~ ' 
     72         WRITE(numout,*) '   nperio = ', nperio, '   nimpp  = ', nimpp 
     73         WRITE(numout,*) '   npolj  = ', npolj , '   njmpp  = ', njmpp 
     74      ENDIF 
     75      ! 
     76      IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 )                                     & 
     77         CALL ctl_stop( 'mpp_init: equality  jpni = jpnj = jpnij = 1 is not satisfied',   & 
     78            &           'the domain is lay out for distributed memory computing!' ) 
     79         ! 
     80      IF( jperio == 7 ) CALL ctl_stop( 'mpp_init: jperio = 7 needs distributed memory computing ',       & 
     81         &                             'with 1 process. Add key_mpp_mpi in the list of active cpp keys ' ) 
     82         ! 
    8083   END SUBROUTINE mpp_init 
    8184 
    82  
    83    SUBROUTINE mpp_init2  
    84       CALL mpp_init                             ! same routine as mpp_init 
    85    END SUBROUTINE mpp_init2 
    86  
    8785#else 
    8886   !!---------------------------------------------------------------------- 
    89    !!   'key_mpp_mpi'          OR         MPI massively parallel processing 
     87   !!   'key_mpp_mpi'                     MPI massively parallel processing 
    9088   !!---------------------------------------------------------------------- 
    9189 
    … …  
    9593      !!                     
    9694      !! ** Purpose :   Lay out the global domain over processors. 
     95      !!      If land processors are to be eliminated, this program requires the 
     96      !!      presence of the domain configuration file. Land processors elimination 
     97      !!      is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP 
     98      !!      preprocessing tool, help for defining the best cutting out. 
    9799      !! 
    98100      !! ** Method  :   Global domain is distributed in smaller local domains. 
    … …  
    103105      !!                     nperio local  periodic condition 
    104106      !! 
    105       !! ** Action  : - set domain parameters 
     107      !! ** Action : - set domain parameters 
    106108      !!                    nimpp     : longitudinal index  
    107109      !!                    njmpp     : latitudinal  index 
    … …  
    117119      !!                    noso      : number for local neighboring processor 
    118120      !!                    nono      : number for local neighboring processor 
    119       !! 
    120       !! History : 
    121       !!        !  94-11  (M. Guyon)  Original code 
    122       !!        !  95-04  (J. Escobar, M. Imbard) 
    123       !!        !  98-02  (M. Guyon)  FETI method 
    124       !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions 
    125       !!   8.5  !  02-08  (G. Madec)  F90 : free form 
    126       !!   3.4  !  11-11  (C. Harris) decomposition changes for running with CICE 
    127       !!---------------------------------------------------------------------- 
    128       INTEGER  ::   ji, jj, jn   ! dummy loop indices 
    129       INTEGER  ::   ii, ij, ifreq, il1, il2            ! local integers 
    130       INTEGER  ::   iresti, irestj, ijm1, imil, inum   !   -      - 
    131       REAL(wp) ::   zidom, zjdom                       ! local scalars 
    132       INTEGER, DIMENSION(jpni,jpnj) ::   iimppt, ijmppt, ilcit, ilcjt   ! local workspace 
    133       !!---------------------------------------------------------------------- 
    134  
    135       IF(lwp) WRITE(numout,*) 
    136       IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing MPI' 
    137       IF(lwp) WRITE(numout,*) '~~~~~~~~' 
    138  
    139  
     121      !!---------------------------------------------------------------------- 
     122      INTEGER ::   ji, jj, jn, jproc, jarea   ! dummy loop indices 
     123      INTEGER ::   inum                       ! local logical unit 
     124      INTEGER ::   idir, ifreq, icont, isurf  ! local integers 
     125      INTEGER ::   ii, il1, ili, imil         !   -       - 
     126      INTEGER ::   ij, il2, ilj, ijm1         !   -       - 
     127      INTEGER ::   iino, ijno, iiso, ijso     !   -       - 
     128      INTEGER ::   iiea, ijea, iiwe, ijwe     !   -       - 
     129      INTEGER ::   iresti, irestj, iproc      !   -       - 
     130      INTEGER, DIMENSION(jpnij) ::   iin, ii_nono, ii_noea   ! 1D workspace 
     131      INTEGER, DIMENSION(jpnij) ::   ijn, ii_noso, ii_nowe   !  -     - 
     132      INTEGER, DIMENSION(jpni,jpnj) ::   iimppt, ilci, ibondi, ipproc   ! 2D workspace 
     133      INTEGER, DIMENSION(jpni,jpnj) ::   ijmppt, ilcj, ibondj, ipolj    !  -     - 
     134      INTEGER, DIMENSION(jpni,jpnj) ::   ilei, ildi, iono, ioea         !  -     - 
     135      INTEGER, DIMENSION(jpni,jpnj) ::   ilej, ildj, ioso, iowe         !  -     - 
     136      INTEGER, DIMENSION(jpiglo,jpjglo) ::   imask   ! 2D golbal domain workspace 
     137      REAL(wp) ::   zidom, zjdom   ! local scalars 
     138      !!---------------------------------------------------------------------- 
     139      ! 
     140      IF ( jpni * jpnj == jpnij ) THEN    ! regular domain lay out over processors 
     141         imask(:,:) = 1                
     142      ELSEIF ( jpni*jpnj > jpnij ) THEN   ! remove land-only processor (i.e. where imask(:,:)=0) 
     143         CALL mpp_init_mask( imask )    
     144      ELSE                                ! error 
     145         CALL ctl_stop( 'mpp_init: jpnij > jpni x jpnj. Check namelist setting!' ) 
     146      ENDIF 
     147      ! 
    140148      !  1. Dimension arrays for subdomains 
    141149      ! ----------------------------------- 
    142       !  Computation of local domain sizes ilcit() ilcjt() 
     150      !  Computation of local domain sizes ilci() ilcj() 
    143151      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo 
    144       !  The subdomains are squares leeser than or equal to the global 
    145       !  dimensions divided by the number of processors minus the overlap 
    146       !  array (cf. par_oce.F90). 
    147        
    148       nreci  = 2 * jpreci 
    149       nrecj  = 2 * jprecj 
    150       iresti = MOD( jpiglo - nreci , jpni ) 
    151       irestj = MOD( jpjglo - nrecj , jpnj ) 
    152  
    153       IF(  iresti == 0 )   iresti = jpni 
    154  
     152      !  The subdomains are squares lesser than or equal to the global 
     153      !  dimensions divided by the number of processors minus the overlap array. 
     154      ! 
     155      nreci = 2 * nn_hls 
     156      nrecj = 2 * nn_hls 
     157      iresti = 1 + MOD( jpiglo - nreci -1 , jpni ) 
     158      irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj ) 
     159      ! 
     160      !  Need to use jpimax and jpjmax here since jpi and jpj have already been 
     161      !  shrunk to local sizes in nemogcm 
    155162#if defined key_nemocice_decomp 
    156       ! In order to match CICE the size of domains in NEMO has to be changed 
    157       ! The last line of blocks (west) will have fewer points 
    158  
    159       DO jj = 1, jpnj 
    160          DO ji=1, jpni-1 
    161             ilcit(ji,jj) = jpi 
    162          END DO 
    163          ilcit(jpni,jj) = jpiglo - (jpni - 1) * (jpi - nreci) 
    164       END DO 
    165  
     163      ! Change padding to be consistent with CICE 
     164      ilci(1:jpni-1      ,:) = jpimax 
     165      ilci(jpni          ,:) = jpiglo - (jpni - 1) * (jpimax - nreci) 
     166      ! 
     167      ilcj(:,      1:jpnj-1) = jpjmax 
     168      ilcj(:,          jpnj) = jpjglo - (jpnj - 1) * (jpjmax - nrecj) 
    166169#else 
    167  
    168       DO jj = 1, jpnj 
    169          DO ji = 1, iresti 
    170             ilcit(ji,jj) = jpi 
    171          END DO 
    172          DO ji = iresti+1, jpni 
    173             ilcit(ji,jj) = jpi -1 
    174          END DO 
    175       END DO 
    176        
     170      ilci(1:iresti      ,:) = jpimax 
     171      ilci(iresti+1:jpni ,:) = jpimax-1 
     172 
     173      ilcj(:,      1:irestj) = jpjmax 
     174      ilcj(:, irestj+1:jpnj) = jpjmax-1 
    177175#endif 
    178       nfilcit(:,:) = ilcit(:,:) 
    179       IF( irestj == 0 )   irestj = jpnj 
    180  
    181 #if defined key_nemocice_decomp 
    182       ! Same change to domains in North-South direction as in East-West.  
    183       DO ji=1,jpni 
    184          DO jj=1,jpnj-1 
    185             ilcjt(ji,jj) = jpj 
    186          END DO 
    187          ilcjt(ji,jpnj) = jpjglo - (jpnj - 1) * (jpj - nrecj) 
    188       END DO 
    189  
    190 #else 
    191  
    192       DO ji = 1, jpni 
    193          DO jj = 1, irestj 
    194             ilcjt(ji,jj) = jpj 
    195          END DO 
    196          DO jj = irestj+1, jpnj 
    197             ilcjt(ji,jj) = jpj -1 
    198          END DO 
    199       END DO 
    200        
    201 #endif 
     176      ! 
     177      nfilcit(:,:) = ilci(:,:) 
     178      ! 
     179      zidom = nreci + sum(ilci(:,1) - nreci ) 
     180      zjdom = nrecj + sum(ilcj(1,:) - nrecj ) 
     181      ! 
     182      IF(lwp) THEN 
     183         WRITE(numout,*) 
     184         WRITE(numout,*) 'mpp_init : MPI Message Passing MPI - domain lay out over processors' 
     185         WRITE(numout,*) '~~~~~~~~ ' 
     186         WRITE(numout,*) '   defines mpp subdomains' 
     187         WRITE(numout,*) '      iresti = ', iresti, ' jpni = ', jpni   
     188         WRITE(numout,*) '      irestj = ', irestj, ' jpnj = ', jpnj 
     189         WRITE(numout,*) 
     190         WRITE(numout,*) '      sum ilci(i,1) = ', zidom, ' jpiglo = ', jpiglo 
     191         WRITE(numout,*) '      sum ilcj(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
     192      ENDIF 
    202193 
    203194      !  2. Index arrays for subdomains 
    204195      ! ------------------------------- 
    205        
    206       iimppt(:,:) = 1 
    207       ijmppt(:,:) = 1 
    208        
     196      iimppt(:,:) =  1 
     197      ijmppt(:,:) = 1 
     198      ipproc(:,:) = -1 
     199      ! 
    209200      IF( jpni > 1 ) THEN 
    210201         DO jj = 1, jpnj 
    211202            DO ji = 2, jpni 
    212                iimppt(ji,jj) = iimppt(ji-1,jj) + ilcit(ji-1,jj) - nreci 
     203               iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci 
    213204            END DO 
    214205         END DO 
    215206      ENDIF 
    216       nfiimpp(:,:)=iimppt(:,:) 
    217  
    218       IF( jpnj > 1 ) THEN 
     207      nfiimpp(:,:) = iimppt(:,:) 
     208      ! 
     209      IF( jpnj > 1 )THEN 
    219210         DO jj = 2, jpnj 
    220211            DO ji = 1, jpni 
    221                ijmppt(ji,jj) = ijmppt(ji,jj-1)+ilcjt(ji,jj-1)-nrecj 
     212               ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj 
    222213            END DO 
    223214         END DO 
    224215      ENDIF 
    225        
    226       ! 3. Subdomain description 
    227       ! ------------------------ 
    228  
    229       DO jn = 1, jpnij 
    230          ii = 1 + MOD( jn-1, jpni ) 
    231          ij = 1 + (jn-1) / jpni 
    232          nfipproc(ii,ij) = jn - 1 
    233          nimppt(jn) = iimppt(ii,ij) 
    234          njmppt(jn) = ijmppt(ii,ij) 
    235          nlcit (jn) = ilcit (ii,ij)      
    236          nlci       = nlcit (jn)      
    237          nlcjt (jn) = ilcjt (ii,ij)      
    238          nlcj       = nlcjt (jn) 
    239          nbondj = -1                                   ! general case 
    240          IF( jn   >  jpni          )   nbondj = 0      ! first row of processor 
    241          IF( jn   >  (jpnj-1)*jpni )   nbondj = 1      ! last  row of processor 
    242          IF( jpnj == 1             )   nbondj = 2      ! one processor only in j-direction 
    243          ibonjt(jn) = nbondj 
    244           
    245          nbondi = 0                                    !  
    246          IF( MOD( jn, jpni ) == 1 )   nbondi = -1      ! 
    247          IF( MOD( jn, jpni ) == 0 )   nbondi =  1      ! 
    248          IF( jpni            == 1 )   nbondi =  2      ! one processor only in i-direction 
    249          ibonit(jn) = nbondi 
    250           
    251          nldi =  1   + jpreci 
    252          nlei = nlci - jpreci 
    253          IF( nbondi == -1 .OR. nbondi == 2 )   nldi = 1 
    254          IF( nbondi ==  1 .OR. nbondi == 2 )   nlei = nlci 
    255          nldj =  1   + jprecj 
    256          nlej = nlcj - jprecj 
    257          IF( nbondj == -1 .OR. nbondj == 2 )   nldj = 1 
    258          IF( nbondj ==  1 .OR. nbondj == 2 )   nlej = nlcj 
    259          nldit(jn) = nldi 
    260          nleit(jn) = nlei 
    261          nldjt(jn) = nldj 
    262          nlejt(jn) = nlej 
     216 
     217      ! 3. Subdomain description in the Regular Case 
     218      ! -------------------------------------------- 
     219      nperio = 0 
     220      icont = -1 
     221      DO jarea = 1, jpni*jpnj 
     222         ii = 1 + MOD(jarea-1,jpni) 
     223         ij = 1 +    (jarea-1)/jpni 
     224         ili = ilci(ii,ij) 
     225         ilj = ilcj(ii,ij) 
     226         ibondj(ii,ij) = -1 
     227         IF( jarea >  jpni          )   ibondj(ii,ij) = 0 
     228         IF( jarea >  (jpnj-1)*jpni )   ibondj(ii,ij) = 1 
     229         IF( jpnj  == 1             )   ibondj(ii,ij) = 2 
     230         ibondi(ii,ij) = 0 
     231         IF( MOD(jarea,jpni) == 1 )   ibondi(ii,ij) = -1 
     232         IF( MOD(jarea,jpni) == 0 )   ibondi(ii,ij) =  1 
     233         IF( jpni            == 1 )   ibondi(ii,ij) =  2 
     234 
     235         ! Subdomain neighbors 
     236         iproc = jarea - 1 
     237         ioso(ii,ij) = iproc - jpni 
     238         iowe(ii,ij) = iproc - 1 
     239         ioea(ii,ij) = iproc + 1 
     240         iono(ii,ij) = iproc + jpni 
     241         ildi(ii,ij) =  1  + nn_hls 
     242         ilei(ii,ij) = ili - nn_hls 
     243 
     244         IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) =  1 
     245         IF( ibondi(ii,ij) ==  1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ili 
     246         ildj(ii,ij) =  1  + nn_hls 
     247         ilej(ii,ij) = ilj - nn_hls 
     248         IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) =  1 
     249         IF( ibondj(ii,ij) ==  1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilj 
     250 
     251         ! warning ii*ij (zone) /= nproc (processors)! 
     252 
     253         IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN 
     254            IF( jpni == 1 )THEN 
     255               ibondi(ii,ij) = 2 
     256               nperio = 1 
     257            ELSE 
     258               ibondi(ii,ij) = 0 
     259            ENDIF 
     260            IF( MOD(jarea,jpni) == 0 ) THEN 
     261               ioea(ii,ij) = iproc - (jpni-1) 
     262            ENDIF 
     263            IF( MOD(jarea,jpni) == 1 ) THEN 
     264               iowe(ii,ij) = iproc + jpni - 1 
     265            ENDIF 
     266         ENDIF 
     267         ipolj(ii,ij) = 0 
     268         IF( jperio == 3 .OR. jperio == 4 ) THEN 
     269            ijm1 = jpni*(jpnj-1) 
     270            imil = ijm1+(jpni+1)/2 
     271            IF( jarea > ijm1 ) ipolj(ii,ij) = 3 
     272            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 
     273            IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour 
     274         ENDIF 
     275         IF( jperio == 5 .OR. jperio == 6 ) THEN 
     276            ijm1 = jpni*(jpnj-1) 
     277            imil = ijm1+(jpni+1)/2 
     278            IF( jarea > ijm1) ipolj(ii,ij) = 5 
     279            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 
     280            IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour 
     281         ENDIF 
     282         ! 
     283         ! Check wet points over the entire domain to preserve the MPI communication stencil 
     284         isurf = 0 
     285         DO jj = 1, ilj 
     286            DO  ji = 1, ili 
     287               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1)   isurf = isurf+1 
     288            END DO 
     289         END DO 
     290         ! 
     291         IF( isurf /= 0 ) THEN 
     292            icont = icont + 1 
     293            ipproc(ii,ij) = icont 
     294            iin(icont+1) = ii 
     295            ijn(icont+1) = ij 
     296         ENDIF 
    263297      END DO 
     298      ! 
     299      nfipproc(:,:) = ipproc(:,:) 
     300 
     301      ! Check potential error 
     302      IF( icont+1 /= jpnij ) THEN 
     303         WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj 
     304         WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj'  
     305         WRITE(ctmp3,*) ' ***********, mpp_init2 finds jpnij=',icont+1 
     306         CALL ctl_stop( 'mpp_init: Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 ) 
     307      ENDIF 
    264308 
    265309      ! 4. Subdomain print 
    266310      ! ------------------ 
    267        
    268       IF(lwp) WRITE(numout,*) 
    269       IF(lwp) WRITE(numout,*) '   defines mpp subdomains' 
    270       IF(lwp) WRITE(numout,*) '      jpni=', jpni, ' iresti=', iresti 
    271       IF(lwp) WRITE(numout,*) '      jpnj=', jpnj, ' irestj=', irestj 
    272       zidom = nreci 
    273       DO ji = 1, jpni 
    274          zidom = zidom + ilcit(ji,1) - nreci 
    275       END DO 
    276       IF(lwp) WRITE(numout,*) 
    277       IF(lwp) WRITE(numout,*)'      sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
    278  
    279       zjdom = nrecj 
    280       DO jj = 1, jpnj 
    281          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    282       END DO 
    283       IF(lwp) WRITE(numout,*)'      sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
    284  
    285311      IF(lwp) THEN 
    286312         ifreq = 4 
    287          il1   = 1 
     313         il1 = 1 
    288314         DO jn = 1, (jpni-1)/ifreq+1 
    289             il2 = MIN( jpni, il1+ifreq-1 ) 
     315            il2 = MIN(jpni,il1+ifreq-1) 
    290316            WRITE(numout,*) 
    291             WRITE(numout,9200) ('***',ji = il1,il2-1) 
     317            WRITE(numout,9400) ('***',ji=il1,il2-1) 
    292318            DO jj = jpnj, 1, -1 
    293                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    294                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    295                WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
    296                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    297                WRITE(numout,9200) ('***',ji = il1,il2-1) 
     319               WRITE(numout,9403) ('   ',ji=il1,il2-1) 
     320               WRITE(numout,9402) jj, (ilci(ji,jj),ilcj(ji,jj),ji=il1,il2) 
     321               WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 
     322               WRITE(numout,9403) ('   ',ji=il1,il2-1) 
     323               WRITE(numout,9400) ('***',ji=il1,il2-1) 
    298324            END DO 
    299             WRITE(numout,9201) (ji,ji = il1,il2) 
     325            WRITE(numout,9401) (ji,ji=il1,il2) 
    300326            il1 = il1+ifreq 
    301327         END DO 
    302  9200     FORMAT('     ***',20('*************',a3)) 
    303  9203     FORMAT('     *     ',20('         *   ',a3)) 
    304  9201     FORMAT('        ',20('   ',i3,'          ')) 
    305  9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    306  9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
    307       ENDIF 
    308  
    309       ! 5. From global to local 
    310       ! ----------------------- 
    311  
    312       nperio = 0 
    313       IF( jperio == 2 .AND. nbondj == -1 )   nperio = 2 
    314  
    315  
    316       ! 6. Subdomain neighbours 
     328 9400    FORMAT('     ***',20('*************',a3)) 
     329 9403    FORMAT('     *     ',20('         *   ',a3)) 
     330 9401    FORMAT('        ',20('   ',i3,'          ')) 
     331 9402    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     332 9404    FORMAT('     *  ',20('      ',i3,'   *   ')) 
     333      ENDIF 
     334 
     335      ! 5. neighbour treatment 
    317336      ! ---------------------- 
    318  
    319       nproc = narea - 1 
    320       noso  = nproc - jpni 
    321       nowe  = nproc - 1 
    322       noea  = nproc + 1 
    323       nono  = nproc + jpni 
    324       ! great neighbours 
    325       npnw = nono - 1 
    326       npne = nono + 1 
    327       npsw = noso - 1 
    328       npse = noso + 1 
    329       nbsw = 1 
    330       nbnw = 1 
    331       IF( MOD( nproc, jpni ) == 0 ) THEN 
    332          nbsw = 0 
    333          nbnw = 0 
    334       ENDIF 
    335       nbse = 1 
    336       nbne = 1 
    337       IF( MOD( nproc, jpni ) == jpni-1 ) THEN 
    338          nbse = 0 
    339          nbne = 0 
    340       ENDIF 
    341       IF(nproc < jpni) THEN 
    342          nbsw = 0 
    343          nbse = 0 
    344       ENDIF 
    345       IF( nproc >= (jpnj-1)*jpni ) THEN 
    346          nbnw = 0 
    347          nbne = 0 
    348       ENDIF 
    349       nlcj = nlcjt(narea)   
    350       nlci = nlcit(narea)   
    351       nldi = nldit(narea) 
    352       nlei = nleit(narea) 
    353       nldj = nldjt(narea) 
    354       nlej = nlejt(narea) 
    355       nbondi = ibonit(narea) 
    356       nbondj = ibonjt(narea) 
    357       nimpp  = nimppt(narea)   
    358       njmpp  = njmppt(narea)   
    359  
    360       ! Save processor layout in layout.dat file  
    361       IF(lwp) THEN 
     337      DO jarea = 1, jpni*jpnj 
     338         iproc = jarea-1 
     339         ii = 1 + MOD( jarea-1  , jpni ) 
     340         ij = 1 +     (jarea-1) / jpni 
     341         IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 
     342            iino = 1 + MOD( iono(ii,ij) , jpni ) 
     343            ijno = 1 +      iono(ii,ij) / jpni 
     344            ! Need to reverse the logical direction of communication  
     345            ! for northern neighbours of northern row processors (north-fold) 
     346            ! i.e. need to check that the northern neighbour only communicates 
     347            ! to the SOUTH (or not at all) if this area is land-only (#1057) 
     348            idir = 1 
     349            IF( ij == jpnj .AND. ijno == jpnj )   idir = -1     
     350            IF( ibondj(iino,ijno) == idir     )   ibondj(iino,ijno) =   2 
     351            IF( ibondj(iino,ijno) == 0        )   ibondj(iino,ijno) = -idir 
     352         ENDIF 
     353         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 
     354            iiso = 1 + MOD( ioso(ii,ij) , jpni ) 
     355            ijso = 1 +      ioso(ii,ij) / jpni 
     356            IF( ibondj(iiso,ijso) == -1 )   ibondj(iiso,ijso) = 2 
     357            IF( ibondj(iiso,ijso) ==  0 )   ibondj(iiso,ijso) = 1 
     358         ENDIF 
     359         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 
     360            iiea = 1 + MOD( ioea(ii,ij) , jpni ) 
     361            ijea = 1 +      ioea(ii,ij) / jpni 
     362            IF( ibondi(iiea,ijea) == 1 )   ibondi(iiea,ijea) =  2 
     363            IF( ibondi(iiea,ijea) == 0 )   ibondi(iiea,ijea) = -1 
     364         ENDIF 
     365         IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 
     366            iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 
     367            ijwe = 1 +      iowe(ii,ij) / jpni 
     368            IF( ibondi(iiwe,ijwe) == -1 )   ibondi(iiwe,ijwe) = 2 
     369            IF( ibondi(iiwe,ijwe) ==  0 )   ibondi(iiwe,ijwe) = 1 
     370         ENDIF 
     371      END DO 
     372 
     373      ! just to save nono etc for all proc 
     374      ii_noso(:) = -1 
     375      ii_nono(:) = -1 
     376      ii_noea(:) = -1 
     377      ii_nowe(:) = -1  
     378      nproc = narea-1 
     379      DO jarea = 1, jpnij 
     380         ii = iin(jarea) 
     381         ij = ijn(jarea) 
     382         IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 
     383            iiso = 1 + MOD( ioso(ii,ij) , jpni ) 
     384            ijso = 1 +      ioso(ii,ij) / jpni 
     385            noso = ipproc(iiso,ijso) 
     386            ii_noso(jarea)= noso 
     387         ENDIF 
     388         IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 
     389          iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 
     390          ijwe = 1 +      iowe(ii,ij) / jpni 
     391          nowe = ipproc(iiwe,ijwe) 
     392          ii_nowe(jarea)= nowe 
     393         ENDIF 
     394         IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 
     395            iiea = 1 + MOD( ioea(ii,ij) , jpni ) 
     396            ijea = 1 +      ioea(ii,ij) / jpni 
     397            noea = ipproc(iiea,ijea) 
     398            ii_noea(jarea)= noea 
     399         ENDIF 
     400         IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 
     401            iino = 1 + MOD( iono(ii,ij) , jpni ) 
     402            ijno = 1 +      iono(ii,ij) / jpni 
     403            nono = ipproc(iino,ijno) 
     404            ii_nono(jarea)= nono 
     405         ENDIF 
     406      END DO 
     407     
     408      ! 6. Change processor name 
     409      ! ------------------------ 
     410      nproc = narea-1 
     411      ii = iin(narea) 
     412      ij = ijn(narea) 
     413      ! 
     414      ! set default neighbours 
     415      noso = ii_noso(narea) 
     416      nowe = ii_nowe(narea) 
     417      noea = ii_noea(narea) 
     418      nono = ii_nono(narea) 
     419      nlcj = ilcj(ii,ij)   
     420      nlci = ilci(ii,ij)   
     421      nldi = ildi(ii,ij) 
     422      nlei = ilei(ii,ij) 
     423      nldj = ildj(ii,ij) 
     424      nlej = ilej(ii,ij) 
     425      nbondi = ibondi(ii,ij) 
     426      nbondj = ibondj(ii,ij) 
     427      nimpp = iimppt(ii,ij)   
     428      njmpp = ijmppt(ii,ij)   
     429      DO jproc = 1, jpnij 
     430         ii = iin(jproc) 
     431         ij = ijn(jproc) 
     432         nimppt(jproc) = iimppt(ii,ij)   
     433         njmppt(jproc) = ijmppt(ii,ij)  
     434         nlcjt(jproc) = ilcj(ii,ij) 
     435         nlcit(jproc) = ilci(ii,ij) 
     436         nldit(jproc) = ildi(ii,ij) 
     437         nleit(jproc) = ilei(ii,ij) 
     438         nldjt(jproc) = ildj(ii,ij) 
     439         nlejt(jproc) = ilej(ii,ij) 
     440      END DO 
     441 
     442      ! Save processor layout in ascii file 
     443      IF (lwp) THEN 
    362444         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    363          WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    364          WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    365          WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    366          ! 
    367          DO jn = 1, jpnij 
    368             WRITE(inum,'(9i5)') jn, nlcit(jn), nlcjt(jn), & 
    369                &                    nldit(jn), nldjt(jn), & 
    370                &                    nleit(jn), nlejt(jn), & 
    371                &                    nimppt(jn), njmppt(jn) 
     445         WRITE(inum,'(a)') '   jpnij   jpimax  jpjmax    jpk  jpiglo  jpjglo'//& 
     446   &           ' ( local:    narea     jpi     jpj)' 
     447         WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 
     448   &           ' ( local: ',narea,jpi,jpj,' )' 
     449         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj ' 
     450 
     451         DO jproc = 1, jpnij 
     452            ii = iin(jproc) 
     453            ij = ijn(jproc) 
     454            WRITE(inum,'(15i5)') jproc-1, nlcit  (jproc), nlcjt  (jproc),   & 
     455               &                          nldit  (jproc), nldjt  (jproc),   & 
     456               &                          nleit  (jproc), nlejt  (jproc),   & 
     457               &                          nimppt (jproc), njmppt (jproc),   &  
     458               &                          ii_nono(jproc), ii_noso(jproc),   & 
     459               &                          ii_nowe(jproc), ii_noea(jproc),   & 
     460               &                          ibondi (ii,ij), ibondj (ii,ij)  
    372461         END DO 
    373462         CLOSE(inum)    
    374463      END IF 
    375464 
    376       ! w a r n i n g  narea (zone) /= nproc (processors)! 
    377  
    378       IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 
    379          IF( jpni == 1 )THEN 
    380             nbondi = 2 
    381             nperio = 1 
    382          ELSE 
    383             nbondi = 0 
    384          ENDIF 
    385          IF( MOD( narea, jpni ) == 0 ) THEN 
    386             noea = nproc-(jpni-1) 
    387             npne = npne-jpni 
    388             npse = npse-jpni 
    389          ENDIF 
    390          IF( MOD( narea, jpni ) == 1 ) THEN 
    391             nowe = nproc+(jpni-1) 
    392             npnw = npnw+jpni 
    393             npsw = npsw+jpni 
    394          ENDIF 
    395          nbsw = 1 
    396          nbnw = 1 
    397          nbse = 1 
    398          nbne = 1 
    399          IF( nproc < jpni ) THEN 
    400             nbsw = 0 
    401             nbse = 0 
    402          ENDIF 
    403          IF( nproc >= (jpnj-1)*jpni ) THEN 
    404             nbnw = 0 
    405             nbne = 0 
    406          ENDIF 
    407       ENDIF 
     465      !                          ! north fold parameter 
     466      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
     467      ! In this case the important thing is that npolj /= 0 
     468      ! Because if we go through these line it is because jpni >1 and thus 
     469      ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 
    408470      npolj = 0 
     471      ij = ijn(narea) 
    409472      IF( jperio == 3 .OR. jperio == 4 ) THEN 
    410          ijm1 = jpni*(jpnj-1) 
    411          imil = ijm1+(jpni+1)/2 
    412          IF( narea > ijm1 ) npolj = 3 
    413          IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 4 
    414          IF( npolj == 3 ) nono = jpni*jpnj-narea+ijm1 
     473         IF( ij == jpnj )   npolj = 3 
    415474      ENDIF 
    416475      IF( jperio == 5 .OR. jperio == 6 ) THEN 
    417           ijm1 = jpni*(jpnj-1) 
    418           imil = ijm1+(jpni+1)/2 
    419           IF( narea > ijm1) npolj = 5 
    420           IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 6 
    421           IF( npolj == 5 ) nono = jpni*jpnj-narea+ijm1 
    422       ENDIF 
    423  
    424       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    425  
     476         IF( ij == jpnj )   npolj = 5 
     477      ENDIF 
     478      ! 
    426479      IF(lwp) THEN 
    427          WRITE(numout,*) '      nproc  = ', nproc 
    428          WRITE(numout,*) '      nowe   = ', nowe  , '      noea   =  ', noea 
    429          WRITE(numout,*) '      nono   = ', nono  , '      noso   =  ', noso 
    430          WRITE(numout,*) '      nbondi = ', nbondi, '      nbondj = ', nbondj 
    431          WRITE(numout,*) '      npolj  = ', npolj 
    432          WRITE(numout,*) '      nperio = ', nperio 
    433          WRITE(numout,*) '      nlci   = ', nlci  , '      nlcj   = ', nlcj 
    434          WRITE(numout,*) '      nimpp  = ', nimpp , '      njmpp  = ', njmpp 
    435          WRITE(numout,*) '      nreci  = ', nreci , '      npse   = ', npse 
    436          WRITE(numout,*) '      nrecj  = ', nrecj , '      npsw   = ', npsw 
    437          WRITE(numout,*) '      jpreci = ', jpreci, '      npne   = ', npne 
    438          WRITE(numout,*) '      jprecj = ', jprecj, '      npnw   = ', npnw 
    439480         WRITE(numout,*) 
    440       ENDIF 
    441  
    442       IF( jperio == 7 .AND. ( jpni /= 1 .OR. jpnj /= 1 ) ) & 
    443          &                  CALL ctl_stop( ' mpp_init: error jperio = 7 works only with jpni = jpnj = 1' ) 
    444       IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init: error on cyclicity' ) 
    445  
    446       ! Prepare mpp north fold 
    447  
     481         WRITE(numout,*) ' nproc  = ', nproc 
     482         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     483         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     484         WRITE(numout,*) ' nbondi = ', nbondi 
     485         WRITE(numout,*) ' nbondj = ', nbondj 
     486         WRITE(numout,*) ' npolj  = ', npolj 
     487         WRITE(numout,*) ' nperio = ', nperio 
     488         WRITE(numout,*) ' nlci   = ', nlci 
     489         WRITE(numout,*) ' nlcj   = ', nlcj 
     490         WRITE(numout,*) ' nimpp  = ', nimpp 
     491         WRITE(numout,*) ' njmpp  = ', njmpp 
     492         WRITE(numout,*) ' nreci  = ', nreci   
     493         WRITE(numout,*) ' nrecj  = ', nrecj   
     494         WRITE(numout,*) ' nn_hls = ', nn_hls  
     495      ENDIF 
     496 
     497      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( 'mpp_init: error on cyclicity' ) 
     498 
     499      !                          ! Prepare mpp north fold 
    448500      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    449501         CALL mpp_ini_north 
    450502         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
    451503      ENDIF 
    452  
    453       ! Prepare NetCDF output file (if necessary) 
    454       CALL mpp_init_ioipsl 
    455  
    456    END SUBROUTINE mpp_init 
    457  
    458 #  include "mppini_2.h90" 
     504      ! 
     505      CALL mpp_init_ioipsl       ! Prepare NetCDF output file (if necessary) 
     506      ! 
     507    END SUBROUTINE mpp_init 
     508 
     509 
     510    SUBROUTINE mpp_init_mask( kmask ) 
     511      !!---------------------------------------------------------------------- 
     512      !!                  ***  ROUTINE mpp_init_mask  *** 
     513      !! 
     514      !! ** Purpose : Read relevant bathymetric information in a global array 
     515      !!              in order to provide a land/sea mask used for the elimination 
     516      !!              of land domains, in an mpp computation. 
     517      !! 
     518      !! ** Method  : Read the namelist ln_zco and ln_isfcav in namelist namzgr 
     519      !!              in order to choose the correct bathymetric information 
     520      !!              (file and variables)   
     521      !!---------------------------------------------------------------------- 
     522      INTEGER, DIMENSION(jpiglo,jpjglo), INTENT(out) ::   kmask   ! global domain  
     523   
     524      INTEGER :: inum   !: logical unit for configuration file 
     525      INTEGER :: ios    !: iostat error flag 
     526      INTEGER ::  ijstartrow                   ! temporary integers 
     527      REAL(wp), DIMENSION(jpiglo,jpjglo) ::   zbot, zbdy          ! global workspace 
     528      REAL(wp) ::   zidom , zjdom          ! local scalars 
     529      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,         & 
     530           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     & 
     531           &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &   
     532           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
     533           &             cn_ice_lim, nn_ice_lim_dta,                           & 
     534           &             rn_ice_tem, rn_ice_sal, rn_ice_age,                 & 
     535           &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 
     536      !!---------------------------------------------------------------------- 
     537      ! 0. initialisation 
     538      ! ----------------- 
     539      CALL iom_open( cn_domcfg, inum ) 
     540      ! 
     541      ! ocean bottom level 
     542      CALL iom_get( inum, jpdom_unknown, 'bottom_level' , zbot , lrowattr=ln_use_jattr )  ! nb of ocean T-points 
     543      ! 
     544      CALL iom_close( inum ) 
     545      ! 
     546      ! 2D ocean mask (=1 if at least one level of the water column is ocean, =0 otherwise) 
     547      WHERE( zbot(:,:) > 0 )   ;   kmask(:,:) = 1 
     548      ELSEWHERE                ;   kmask(:,:) = 0 
     549      END WHERE 
     550   
     551      ! Adjust kmask with bdy_msk if it exists 
     552   
     553      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist : BDY 
     554      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
     555903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp ) 
     556 
     557      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist : BDY 
     558      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 
     559904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp ) 
     560 
     561      IF( ln_bdy .AND. ln_mask_file ) THEN 
     562         CALL iom_open( cn_mask_file, inum ) 
     563         CALL iom_get ( inum, jpdom_unknown, 'bdy_msk', zbdy ) 
     564         CALL iom_close( inum ) 
     565         WHERE ( zbdy(:,:) <= 0. ) kmask = 0 
     566      ENDIF 
     567      ! 
     568   END SUBROUTINE mpp_init_mask 
     569 
    459570 
    460571   SUBROUTINE mpp_init_ioipsl 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r8974 r9012  
    235235      INTEGER  ::   ji                 ! dummy loop indices 
    236236      INTEGER  ::   ios, ilocal_comm   ! local integer 
     237      INTEGER  ::   iiarea, ijarea     ! local integers 
     238      INTEGER  ::   iirest, ijrest     ! local integers 
    237239      CHARACTER(len=120), DIMENSION(30) ::   cltxt, cltxt2, clnam 
    238240      ! 
    … …  
    278280      ENDIF 
    279281      ! 
    280       jpk = jpkglo 
    281       ! 
    282 #if defined key_agrif 
    283       IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90) 
    284          jpiglo  = nbcellsx + 2 + 2*nbghostcells 
    285          jpjglo  = nbcellsy + 2 + 2*nbghostcells 
    286          jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    287          jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    288          nperio  = 0 
    289          jperio  = 0 
    290          ln_use_jattr = .false. 
    291       ENDIF 
    292 #endif 
    293282      ! 
    294283      !                             !--------------------------------------------! 
    … …  
    349338#endif 
    350339      ENDIF 
     340      ! 
     341#if defined key_agrif 
     342      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90) 
     343         jpiglo  = nbcellsx + 2 + 2*nbghostcells 
     344         jpjglo  = nbcellsy + 2 + 2*nbghostcells 
     345         jpi     = ( jpiglo-2*nn_hls + (jpni-1+0) ) / jpni + 2*nn_hls 
     346         jpj     = ( jpjglo-2*nn_hls + (jpnj-1+0) ) / jpnj + 2*nn_hls 
     347         jpimax  = jpi 
     348         jpjmax  = jpj 
     349         nperio  = 0 
     350         jperio  = 0 
     351         ln_use_jattr = .false. 
     352      ENDIF 
     353#endif 
    351354 
    352355      IF( Agrif_Root() ) THEN       ! AGRIF mother: specific setting from jpni and jpnj 
     356         iiarea = 1 + MOD( narea - 1 , jpni ) 
     357         ijarea = 1 + ( narea - 1 ) / jpni 
     358         iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni ) 
     359         ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj ) 
    353360#if defined key_nemocice_decomp 
    354          jpi = ( nx_global+2-2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    355          jpj = ( ny_global+2-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim.  
     361         jpi = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     362         jpj = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.  
     363         jpimax  = jpi 
     364         jpjmax  = jpj 
     365         IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls) 
     366         IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls) 
    356367#else 
    357          jpi = ( jpiglo     -2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    358          jpj = ( jpjglo     -2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim. 
    359 #endif 
    360       ENDIF 
    361  
    362 !!gm ???    why here  it has already been done in line 301 ! 
     368         jpi = ( jpiglo     -2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     369         jpj = ( jpjglo     -2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim. 
     370         jpimax  = jpi 
     371         jpjmax  = jpj 
     372         IF( iiarea > iirest ) jpi = jpi - 1 
     373         IF( ijarea > ijrest ) jpj = jpj - 1 
     374#endif 
     375      ENDIF 
     376 
    363377      jpk = jpkglo                                             ! third dim 
    364 !!gm end 
    365378 
    366379#if defined key_agrif 
    … …  
    409422 
    410423      !                                      ! Domain decomposition 
    411       IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out 
    412       ELSE                            ;   CALL mpp_init2     ! eliminate land processors 
    413       ENDIF 
     424      CALL mpp_init 
     425      IF( ln_nnogather )    CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 
    414426      ! 
    415427      IF( ln_timing    )   CALL timing_init 
    … …  
    422434                           CALL     dom_init   ! Domain 
    423435      IF( ln_crs       )   CALL     crs_init   ! coarsened grid: domain initialization  
    424       IF( ln_nnogather )   CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 
     436      !IF( ln_nnogather )    CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 
    425437      IF( ln_ctl       )   CALL prt_ctl_init   ! Print control 
    426438       

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/par_oce.F90

    r7646 r9012  
    5454 
    5555   ! local domain size                !!! * local computational domain * 
    56    INTEGER, PUBLIC ::   jpi   ! = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   !: first  dimension 
    57    INTEGER, PUBLIC ::   jpj   ! = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   !: second dimension 
     56   INTEGER, PUBLIC ::   jpi   ! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls   !: first  dimension 
     57   INTEGER, PUBLIC ::   jpj   ! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls   !: second dimension 
    5858   INTEGER, PUBLIC ::   jpk   ! = jpkglo 
    5959   INTEGER, PUBLIC ::   jpim1 ! = jpi-1                                            !: inner domain indices 
    … …  
    6161   INTEGER, PUBLIC ::   jpkm1 ! = jpk-1                                            !:   -     -      - 
    6262   INTEGER, PUBLIC ::   jpij  ! = jpi*jpj                                          !:  jpi x jpj 
     63   INTEGER, PUBLIC ::   jpimax! = maximum jpi across all areas  
     64   INTEGER, PUBLIC ::   jpjmax! = maximum jpj across all areas 
    6365 
    6466   !!--------------------------------------------------------------------- 
    … …  
    7880   INTEGER, PUBLIC, PARAMETER ::   jpr2di = 0   !: number of columns for extra outer halo  
    7981   INTEGER, PUBLIC, PARAMETER ::   jpr2dj = 0   !: number of rows    for extra outer halo  
    80    INTEGER, PUBLIC, PARAMETER ::   jpreci = 1   !: number of columns for overlap  
    81    INTEGER, PUBLIC, PARAMETER ::   jprecj = 1   !: number of rows    for overlap  
     82   INTEGER, PUBLIC, PARAMETER ::   nn_hls = 1   !: halo width (applies to both rows and columns) 
    8283 
    8384   !!---------------------------------------------------------------------- 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90

    r8882 r9012  
    9393      INTEGER ::   ji                 ! dummy loop indices 
    9494      INTEGER ::   ios, ilocal_comm   ! local integer 
     95      INTEGER  ::   iiarea, ijarea     ! local integers 
     96      INTEGER  ::   iirest, ijrest     ! local integers 
    9597      CHARACTER(len=120), DIMENSION(30) ::   cltxt, cltxt2, clnam 
    9698      ! 
    … …  
    209211#endif 
    210212      ENDIF 
     213      ! 
     214#if defined key_agrif 
     215      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90) 
     216         jpiglo  = nbcellsx + 2 + 2*nbghostcells 
     217         jpjglo  = nbcellsy + 2 + 2*nbghostcells 
     218         jpi     = ( jpiglo-2*nn_hls + (jpni-1+0) ) / jpni + 2*nn_hls 
     219         jpj     = ( jpjglo-2*nn_hls + (jpnj-1+0) ) / jpnj + 2*nn_hls 
     220         jpimax  = jpi 
     221         jpjmax  = jpj 
     222         nperio  = 0 
     223         jperio  = 0 
     224         ln_use_jattr = .false. 
     225      ENDIF 
     226#endif 
    211227 
    212228      IF( Agrif_Root() ) THEN       ! AGRIF mother: specific setting from jpni and jpnj 
     229         iiarea = 1 + MOD( narea - 1 , jpni ) 
     230         ijarea = 1 + ( narea - 1 ) / jpni 
     231         iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni ) 
     232         ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj ) 
    213233#if defined key_nemocice_decomp 
    214          jpi = ( nx_global+2-2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    215          jpj = ( ny_global+2-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim.  
     234         jpi = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     235         jpj = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.  
     236         jpimax  = jpi 
     237         jpjmax  = jpj 
     238         IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls) 
     239         IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls) 
    216240#else 
    217          jpi = ( jpiglo     -2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    218          jpj = ( jpjglo     -2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim. 
    219 #endif 
    220       ENDIF 
    221  
    222 !!gm ???    why here  it has already been done in line 301 ! 
     241         jpi = ( jpiglo     -2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     242         jpj = ( jpjglo     -2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim. 
     243         jpimax  = jpi 
     244         jpjmax  = jpj 
     245         IF( iiarea > iirest ) jpi = jpi - 1 
     246         IF( ijarea > ijrest ) jpj = jpj - 1 
     247#endif 
     248      ENDIF 
     249 
    223250      jpk = jpkglo                                             ! third dim 
    224 !!gm end 
     251 
     252#if defined key_agrif 
     253      ! simple trick to use same vertical grid as parent but different number of levels:  
     254      ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 
     255      ! Suppress once vertical online interpolation is ok 
     256      IF(.NOT.Agrif_Root())   jpkglo = Agrif_Parent( jpkglo ) 
     257#endif 
    225258      jpim1 = jpi-1                                            ! inner domain indices 
    226259      jpjm1 = jpj-1                                            !   "           " 
    227       jpkm1 = jpk-1                                            !   "           " 
     260      jpkm1 = MAX( 1, jpk-1 )                                  !   "           " 
    228261      jpij  = jpi*jpj                                          !  jpi x j 
    229262 
    … …  
    261294      CALL nemo_ctl                             ! Control prints & Benchmark 
    262295 
    263       !                                         ! Domain decomposition 
    264       IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out 
    265       ELSE                            ;   CALL mpp_init2     ! eliminate land processors 
    266       ENDIF 
     296      !                                      ! Domain decomposition 
     297      CALL mpp_init 
    267298      ! 
    268299      IF( ln_timing    )   CALL timing_init     ! timing by routine 
    … …  
    384415      ! 
    385416      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file 
    386       IF( numsol          /= -1 )   CLOSE( numsol          )   ! solver file 
     417      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file 
    387418      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist 
    388419      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist 

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r8885 r9012  
    163163      INTEGER  ::   ilocal_comm   ! local integer 
    164164      INTEGER  ::   ios, inum     !   -      - 
     165      INTEGER  ::   iiarea, ijarea     ! local integers 
     166      INTEGER  ::   iirest, ijrest     ! local integers 
    165167      CHARACTER(len=120), DIMENSION(30) ::   cltxt, cltxt2, clnam 
    166168      CHARACTER(len=80)                 ::   clname 
    … …  
    216218      ENDIF 
    217219      ! 
    218       jpk = jpkglo 
    219       ! 
    220 #if defined key_agrif 
    221       IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90) 
    222          jpiglo  = nbcellsx + 2 + 2*nbghostcells 
    223          jpjglo  = nbcellsy + 2 + 2*nbghostcells 
    224          jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    225          jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    226          nperio  = 0 
    227          jperio  = 0 
    228          ln_use_jattr = .false. 
    229       ENDIF 
    230 #endif 
    231220      ! 
    232221      !                             !--------------------------------------------! 
    … …  
    285274#endif 
    286275      ENDIF 
     276      ! 
     277#if defined key_agrif 
     278      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90) 
     279         jpiglo  = nbcellsx + 2 + 2*nbghostcells 
     280         jpjglo  = nbcellsy + 2 + 2*nbghostcells 
     281         jpi     = ( jpiglo-2*nn_hls + (jpni-1+0) ) / jpni + 2*nn_hls 
     282         jpj     = ( jpjglo-2*nn_hls + (jpnj-1+0) ) / jpnj + 2*nn_hls 
     283         jpimax  = jpi 
     284         jpjmax  = jpj 
     285         nperio  = 0 
     286         jperio  = 0 
     287         ln_use_jattr = .false. 
     288      ENDIF 
     289#endif 
    287290 
    288291      IF( Agrif_Root() ) THEN       ! AGRIF mother: specific setting from jpni and jpnj 
     292         iiarea = 1 + MOD( narea - 1 , jpni ) 
     293         ijarea = 1 + ( narea - 1 ) / jpni 
     294         iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni ) 
     295         ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj ) 
    289296#if defined key_nemocice_decomp 
    290          jpi = ( nx_global+2-2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    291          jpj = ( ny_global+2-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim.  
     297         jpi = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     298         jpj = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.  
     299         jpimax  = jpi 
     300         jpjmax  = jpj 
     301         IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls) 
     302         IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls) 
    292303#else 
    293          jpi = ( jpiglo     -2*jpreci + (jpni-1) ) / jpni + 2*jpreci    ! first  dim. 
    294          jpj = ( jpjglo     -2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj    ! second dim. 
    295 #endif 
    296       ENDIF 
     304         jpi = ( jpiglo     -2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim. 
     305         jpj = ( jpjglo     -2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim. 
     306         jpimax  = jpi 
     307         jpjmax  = jpj 
     308         IF( iiarea > iirest ) jpi = jpi - 1 
     309         IF( ijarea > ijrest ) jpj = jpj - 1 
     310#endif 
     311      ENDIF 
     312 
     313      jpk = jpkglo                                             ! third dim 
    297314 
    298315#if defined key_agrif 
    … …  
    345362 
    346363      !                                      ! Domain decomposition 
    347       IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out 
    348       ELSE                            ;   CALL mpp_init2     ! eliminate land processors 
    349       ENDIF 
     364      CALL mpp_init 
    350365      ! 
    351366      IF( ln_timing    )   CALL timing_init 

  • branches/2017/dev_CNRS_2017/NEMOGCM/SETTE/sette_rpt.sh

    r8896 r9012  
    2222  nam=$2 
    2323  pass=$3 
     24 
    2425# 
    2526  if [ -d $vdir/$nam ]; then 
    … …  
    336337  mach=`grep "COMPILER=" ./sette.sh | sed -e 's/COMPILER=//'` 
    337338  NEMO_VALID=`grep "NEMO_VALIDATION_DIR=" ./param.cfg | sed -e 's/NEMO_VALIDATION_DIR=//'` 
    338 # Directory to run the tests 
    339  SETTE_DIR=$(cd $(dirname "$0"); pwd) 
    340  MAIN_DIR=$(dirname $SETTE_DIR) 
    341  CONFIG_DIR0=${MAIN_DIR}/CONFIG 
    342  TOOLS_DIR=${MAIN_DIR}/TOOLS 
    343  COMPIL_DIR=${TOOLS_DIR}/COMPILE 
    344  NPROC=32 
    345  
    346   SAS_RESTART_DIR=${CONFIG_DIR0}/SAS_ST 
     339  NEMO_VALID=`eval "echo $NEMO_VALID"` 
    347340# 
    348341  if [ ! -d $NEMO_VALID ]; then 
    … …  
    350343    exit 
    351344  fi 
     345# 
     346# Directory to run the tests 
     347  SETTE_DIR=$(cd $(dirname "$0"); pwd) 
     348  MAIN_DIR=$(dirname $SETTE_DIR) 
     349  CONFIG_DIR0=${MAIN_DIR}/CONFIG 
     350  TOOLS_DIR=${MAIN_DIR}/TOOLS 
     351  COMPIL_DIR=${TOOLS_DIR}/COMPILE 
     352  NPROC=32 
     353  SAS_RESTART_DIR=${CONFIG_DIR0}/SAS_ST 
    352354# 
    353355# Show current revision tag and branch name 
Note: See TracChangeset for help on using the changeset viewer.