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

Changeset 15349


Ignore:
Timestamp:
2021-10-08T15:16:52+02:00 (8 months ago)
Author:
cetlod
Message:

dev_PISCO : update with trunk@15348

Location:
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO
Files:
1 deleted
70 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg

    r14963 r15349  
    6565   sn_trcdta(14) = 'data_FER_nomask.nc',        -1         ,  'Fer'    ,    .true.    , .true. , 'yearly'  , 'weights_3D_r360x180_bilin.nc'       , ''   , '' 
    6666   sn_trcdta(23) = 'data_NO3_nomask.nc',        -1         ,  'NO3'    ,    .true.    , .true. , 'yearly'  , 'weights_3D_r360x180_bilin.nc'       , ''   , '' 
    67    rn_trfac(1)   =   1.028e-06   !  multiplicative factor 
    68    rn_trfac(2)   =   1.028e-06   !  -      -      -     - 
    69    rn_trfac(3)   =  44.6e-06     !  -      -      -     - 
    70    rn_trfac(5)   = 117.0e-06     !  -      -      -     - 
    71    rn_trfac(7)   =   1.0e-06     !  -      -      -     - 
    72    rn_trfac(10)  =   1.0e-06     !  -      -      -     - 
    73    rn_trfac(14)  =   1.0e-06     !  -      -      -     - 
    74    rn_trfac(23)  =   7.3125e-06  !  -      -      -     - 
     67   rn_trfac(1)   =   1.028e-06  !  multiplicative factor 
     68   rn_trfac(2)   =   1.028e-06  !  -      -      -     - 
     69   rn_trfac(3)   =  44.6e-06  !  -      -      -     - 
     70   rn_trfac(5)   = 122.0e-06  !  -      -      -     - 
     71   rn_trfac(7)   =   1.0e-06  !  -      -      -     - 
     72   rn_trfac(10)  =   1.0e-06  !  -      -      -     - 
     73   rn_trfac(14)  =   1.0e-06  !  -      -      -     - 
     74   rn_trfac(23)  =   7.6e-06  !  -      -      -     - 
    7575/ 
    7676!----------------------------------------------------------------------- 
     
    118118   rn_trsfac(14) = 6.2667860e-04    !  (  0.035 / 55.85 ) 
    119119   rn_trsfac(23) = 5.2232143e-01    !  ( From kgN m-2 s-1 to molC l-1 ====> zfact = 7.3125/14 ) 
    120    rn_sbc_time   =  1.              !  Time scaling factor for SBC and CBC data (seconds in a day) 
     120   rn_sbc_time   = 1.               !  Time scaling factor for SBC and CBC data (seconds in a day) 
    121121   ! 
    122122   sn_trccbc(1)  = 'river.orca'      ,    120            , 'riverdic'    ,  .true.      , .true. , 'yearly'  , ''       , ''    , '' 
     
    127127   sn_trccbc(14) = 'river.orca'      ,    120            , 'riverdic'    ,  .true.      , .true. , 'yearly'  , ''       , ''    , '' 
    128128   sn_trccbc(23) = 'river.orca'      ,    120            , 'riverdin'    ,  .true.      , .true. , 'yearly'  , ''       , ''    , '' 
    129    rn_trcfac(1)  = 8.333e+01      !  ( data in Mg/m2/yr : 1e3/12/ryyss) 
    130    rn_trcfac(2)  = 8.333e+01      !  ( 1e3 /12 ) 
    131    rn_trcfac(5)  = 3.774193e+04   !  ( 1e3 / 31. * 117 ) 
     129   rn_trcfac(1)  = 8.333333e+01      !  ( data in Mg/m2/yr : 1e3/12/ryyss) 
     130   rn_trcfac(2)  = 8.333333e+01      !  ( 1e3 /12 ) 
     131   rn_trcfac(5)  = 3.774193e+03   !  ( 1e3 / 31. * 117 ) 
    132132   rn_trcfac(7)  = 3.558719e+01   !  ( 1e3 / 28.1 ) 
    133133   rn_trcfac(10) = 8.333333e+01   !  ( 1e3 / 12 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/SHARED/field_def_nemo-oce.xml

    r15127 r15349  
    12431243 
    12441244  <!-- 25h diagnostic output --> 
    1245   <field_group id="25h_grid_T" grid_ref="grid_T_3D" operation="instant"> 
     1245  <field_group id="25h_grid_T" grid_ref="grid_T_3D_inner" operation="instant"> 
    12461246    <field id="temper25h"         name="potential temperature 25h mean"    unit="degC" /> 
    12471247    <field id="tempis25h"         name="insitu temperature 25h mean"    unit="degC" /> 
    12481248    <field id="salin25h"          name="salinity 25h mean"                 unit="psu"  /> 
    1249     <field id="ssh25h"            name="sea surface height 25h mean"  grid_ref="grid_T_2D"      unit="m"    /> 
    1250   </field_group> 
    1251  
    1252   <field_group id="25h_grid_U" grid_ref="grid_U_3D" operation="instant" > 
     1249    <field id="ssh25h"            name="sea surface height 25h mean"  grid_ref="grid_T_2D_inner"      unit="m"    /> 
     1250  </field_group> 
     1251 
     1252  <field_group id="25h_grid_U" grid_ref="grid_U_3D_inner" operation="instant" > 
    12531253    <field id="vozocrtx25h"         name="i current 25h mean"    unit="m/s"   /> 
    12541254  </field_group> 
    12551255 
    1256   <field_group id="25h_grid_V" grid_ref="grid_V_3D" operation="instant"> 
     1256  <field_group id="25h_grid_V" grid_ref="grid_V_3D_inner" operation="instant"> 
    12571257    <field id="vomecrty25h"         name="j current 25h mean"    unit="m/s"    /> 
    12581258  </field_group> 
    12591259 
    1260   <field_group id="25h_grid_W" grid_ref="grid_W_3D" operation="instant"> 
     1260  <field_group id="25h_grid_W" grid_ref="grid_W_3D_inner" operation="instant"> 
    12611261    <field id="vovecrtz25h"         name="k current 25h mean"                 unit="m/s"      /> 
    12621262    <field id="avt25h"              name="vertical diffusivity25h mean"       unit="m2/s" /> 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/SHARED/grid_def_nemo.xml

    r15127 r15349  
    8787  </grid> 
    8888  <grid id="grid_W_3D_inner" > 
    89     <domain domain_ref="grid_W" /> 
    90     <axis axis_ref="depthw_inner" /> 
     89    <domain domain_ref="grid_W_inner" /> 
     90    <axis axis_ref="depthw" /> 
    9191  </grid> 
    9292  <!--  --> 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/ice.F90

    r14103 r15349  
    147147   ! 
    148148   !                                     !!** ice-ridging/rafting namelist (namdyn_rdgrft) ** 
     149   LOGICAL,  PUBLIC ::   ln_str_H79       !: ice strength parameterization (Hibler79) (may be used in rheology) 
    149150   REAL(wp), PUBLIC ::   rn_crhg          !: determines changes in ice strength (also used for landfast param) 
     151   REAL(wp), PUBLIC ::   rn_pstar         !: determines ice strength, Hibler JPO79 (may be used in rheology) 
    150152   ! 
    151153   !                                     !!** ice-rheology namelist (namdyn_rhg) ** 
     
    251253   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_oce,v_oce     !: surface ocean velocity used in ice dynamics 
    252254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ht_i_new        !: ice collection thickness accreted in leads 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fraz_frac       !: fraction of frazil ice accreted at the ice bottom 
    253256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   strength        !: ice strength 
    254257   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   stress1_i, stress2_i, stress12_i   !: 1st, 2nd & diagonal stress tensor element 
     
    453456 
    454457      ii = 1 
    455       ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) , ht_i_new  (jpi,jpj) , strength(jpi,jpj) ,  & 
    456          &      stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) ,                      & 
    457          &      delta_i  (jpi,jpj) , divu_i   (jpi,jpj) , shear_i   (jpi,jpj) ,                      & 
    458          &      aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv  (jpi,jpj) , STAT=ierr(ii) ) 
     458      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) , ht_i_new (jpi,jpj) , fraz_frac (jpi,jpj) ,  & 
     459         &      strength (jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) ,  & 
     460         &      delta_i  (jpi,jpj) , divu_i   (jpi,jpj) , shear_i  (jpi,jpj) ,                        & 
     461         &      aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , STAT=ierr(ii) ) 
    459462 
    460463      ii = ii + 1 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icealb.F90

    r15127 r15349  
    3030   PUBLIC   ice_alb        ! called in icesbc.F90 and iceupdate.F90 
    3131 
    32    REAL(wp), PUBLIC, PARAMETER ::   rn_alb_oce = 0.066   !: ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
     32   REAL(wp), PUBLIC, PARAMETER ::   rn_alb_oce = 0.066_wp   !: ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
    3333   ! 
    3434   !                             !!* albedo namelist (namalb) 
     
    111111      REAL(wp) ::   zalb_snw, zafrac_snw      ! snow-covered sea ice albedo & relative snow fraction 
    112112      REAL(wp) ::   zalb_cs, zalb_os          ! albedo of ice under clear/overcast sky 
     113      !! clem 
     114      REAL(wp), PARAMETER ::   zhi_albcst = 1.5_wp ! pivotal thickness (should be in the namelist) 
    113115      !!--------------------------------------------------------------------- 
    114116      ! 
    115117      IF( ln_timing )   CALL timing_start('icealb') 
    116118      ! 
    117       z1_href_pnd = 1. / 0.05 
    118       z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) )  
    119       z1_c2 = 1. / 0.05 
    120       z1_c3 = 1. / 0.02 
    121       z1_c4 = 1. / 0.03 
     119      z1_href_pnd = 1._wp / 0.05_wp 
     120      z1_c1 = 1._wp / ( LOG(zhi_albcst) - LOG(0.05_wp) )  
     121      z1_c2 = 1._wp / 0.05_wp 
     122      z1_c3 = 1._wp / 0.02_wp 
     123      z1_c4 = 1._wp / 0.03_wp 
    122124      ! 
    123125      CALL ice_var_snwfra( ph_snw, za_s_fra )   ! calculate ice fraction covered by snow 
     
    148150            ENDIF 
    149151            !                       !--- Bare ice albedo (for hi < 150cm) 
    150             IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm 
    151                zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 
    152             ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm 
    153                zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
     152            IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= zhi_albcst ) THEN      ! 5cm < hi < 150cm 
     153               zalb_ice = zalb_ice    + ( 0.18_wp - zalb_ice   ) * z1_c1 * ( LOG(zhi_albcst) - LOG(ph_ice(ji,jj,jl)) ) 
     154            ELSEIF( ph_ice(ji,jj,jl) <= 0.05_wp ) THEN                               ! 0cm < hi < 5cm 
     155               zalb_ice = rn_alb_oce  + ( 0.18_wp - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
    154156            ENDIF 
    155157            ! 
     
    166168            zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
    167169            ! 
    168             zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os  & 
    169                &                  + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 
     170            zalb_cs = zalb_os - ( - 0.1010_wp * zalb_os * zalb_os  & 
     171               &                  + 0.1933_wp * zalb_os - 0.0148_wp ) * tmask(ji,jj,1) 
    170172            ! 
    171173            ! albedo depends on cloud fraction because of non-linear spectral effects 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icecor.F90

    r15127 r15349  
    5353      INTEGER, INTENT(in) ::   kn    ! 1 = after dyn ; 2 = after thermo 
    5454      ! 
    55       INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
     55      INTEGER  ::   ji, jj, jl       ! dummy loop indices 
    5656      REAL(wp) ::   zsal, zzc 
    5757      !!---------------------------------------------------------------------- 
     
    9999         END DO 
    100100      ENDIF 
    101  
     101      ! 
    102102      IF( kn /= 0 ) THEN   ! no zapsmall if kn=0 (for bdy for instance) because we do not want ice-ocean exchanges (wfx,sfx,hfx) 
    103103         !                                                              otherwise conservation diags will fail 
     
    105105         CALL ice_var_zapsmall      !  Zap small values                                  ! 
    106106         !                          !----------------------------------------------------- 
    107       ENDIF 
    108       !                             !----------------------------------------------------- 
    109       IF( kn == 2 ) THEN            !  Ice drift case: Corrections to avoid wrong values ! 
    110          DO_2D( 0, 0, 0, 0 )        !----------------------------------------------------- 
    111             IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
    112                IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
    113                IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
    114                IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
    115                IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
    116             ENDIF 
    117          END_2D 
    118          CALL lbc_lnk( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 
    119107      ENDIF 
    120108      ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rdgrft.F90

    r15127 r15349  
    5757   ! 
    5858   ! ** namelist (namdyn_rdgrft) ** 
    59    LOGICAL  ::   ln_str_H79       ! ice strength parameterization (Hibler79) 
    60    REAL(wp) ::   rn_pstar         ! determines ice strength, Hibler JPO79 
    6159   REAL(wp) ::   rn_csrdg         ! fraction of shearing energy contributing to ridging 
    6260   LOGICAL  ::   ln_partf_lin     ! participation function linear (Thorndike et al. (1975)) 
     
    272270 
    273271      ! controls 
    274       IF( sn_cfctl%l_prtctl )   CALL ice_prt3D   ('icedyn_rdgrft')                                                        ! prints 
     272      IF( sn_cfctl%l_prtctl )   CALL ice_prt3D('icedyn_rdgrft')                                                           ! prints 
    275273      IF( ln_icectl    )   CALL ice_prt     (kt, iiceprt, jiceprt,-1, ' - ice dyn rdgrft - ')                             ! prints 
    276274      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
     
    520518      ! 
    521519      INTEGER , DIMENSION(jpij) ::   itest_rdg, itest_rft   ! test for conservation 
     520      LOGICAL , DIMENSION(jpij) ::   ll_shift         ! logical for doing calculation or not 
    522521      !!------------------------------------------------------------------- 
    523522      ! 
     
    540539         DO ji = 1, npti 
    541540 
    542             IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN   ! only if ice is ridging 
     541            ! set logical to true when ridging 
     542            IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN   ;   ll_shift(ji) = .TRUE. 
     543            ELSE                                                                ;   ll_shift(ji) = .FALSE. 
     544            ENDIF 
     545             
     546            IF( ll_shift(ji) ) THEN   ! only if ice is ridging 
    543547 
    544548               IF( a_i_2d(ji,jl1) > epsi10 ) THEN   ;   z1_ai(ji) = 1._wp / a_i_2d(ji,jl1) 
     
    630634         DO jk = 1, nlay_s 
    631635            DO ji = 1, npti 
    632                IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN 
     636               IF( ll_shift(ji) ) THEN 
    633637                  ! Compute ridging /rafting fractions 
    634638                  afrdg = aridge(ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji) 
     
    651655         DO jk = 1, nlay_i 
    652656            DO ji = 1, npti 
    653                IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN 
     657               IF( ll_shift(ji) ) THEN 
    654658                  ! Compute ridging /rafting fractions 
    655659                  afrdg = aridge(ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji) 
     
    674678            DO ji = 1, npti 
    675679 
    676                IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN 
     680               IF( ll_shift(ji) ) THEN 
    677681 
    678682                  ! Compute the fraction of ridged ice area and volume going to thickness category jl2 
     
    731735            DO jk = 1, nlay_s 
    732736               DO ji = 1, npti 
    733                   IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp )   & 
     737                  IF( ll_shift(ji) )   & 
    734738                     &   ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ( esrdg(ji,jk) * rn_fsnwrdg * fvol(ji)  +  & 
    735739                     &                                               esrft(ji,jk) * rn_fsnwrft * zswitch(ji) ) 
     
    740744            DO jk = 1, nlay_i 
    741745               DO ji = 1, npti 
    742                   IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp )   & 
     746                  IF( ll_shift(ji) )   & 
    743747                     &   ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + eirdg(ji,jk) * fvol(ji) + eirft(ji,jk) * zswitch(ji) 
    744748               END DO 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rhg_evp.F90

    r15127 r15349  
    5252   INTEGER ::   nvarid   ! netcdf variable id 
    5353   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   fimask   ! mask at F points for the ice 
    54  
     54    
    5555   !! * Substitutions 
    5656#  include "do_loop_substitute.h90" 
     
    180180      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xatrp     ! X-component of area transport (m2/s) 
    181181      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_yatrp     ! Y-component of area transport (m2/s) 
     182      !! -- advect fields at the rheology time step for the calculation of strength 
     183      LOGICAL  ::   ll_advups = .FALSE. 
     184      REAL(wp) ::   zdt_ups 
     185      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   ztmp 
     186      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   za_i_ups, zv_i_ups   ! tracers advected upstream 
    182187      !!------------------------------------------------------------------- 
    183188 
     
    234239         z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
    235240      ELSE 
    236          zdtevp   = rdt_ice 
     241         zdtevp   = rDt_ice 
    237242         ! zalpha parameters set later on adaptatively 
    238243      ENDIF 
     
    280285 
    281286         ! Ocean currents at U-V points 
    282          v_oceU(ji,jj)   = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 
    283          u_oceV(ji,jj)   = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 
     287         ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility) 
     288         v_oceU(ji,jj)   = 0.25_wp * ( (v_oce(ji,jj) + v_oce(ji,jj-1)) + (v_oce(ji+1,jj) + v_oce(ji+1,jj-1)) ) * umask(ji,jj,1) 
     289         u_oceV(ji,jj)   = 0.25_wp * ( (u_oce(ji,jj) + u_oce(ji-1,jj)) + (u_oce(ji,jj+1) + u_oce(ji-1,jj+1)) ) * vmask(ji,jj,1) 
    284290 
    285291         ! m/dt 
     
    382388            zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 
    383389 
    384          END_2D 
    385          CALL lbc_lnk( 'icedyn_rhg_evp', zdelta, 'T', 1.0_wp ) 
    386  
    387          ! P/delta at T points 
    388          DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     390            ! P/delta at T points 
    389391            zp_delt(ji,jj) = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl ) 
    390          END_2D 
    391  
     392 
     393         END_2D 
     394         CALL lbc_lnk( 'icedyn_rhg_evp', zdelta, 'T', 1.0_wp, zp_delt, 'T', 1.0_wp ) 
     395 
     396         ! 
    392397         DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )   ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 
    393398 
    394399            ! divergence at T points (duplication to avoid communications) 
    395             zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    396                &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     400            ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility) 
     401            zdiv  = ( (e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj))   & 
     402               &    + (e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1))   & 
    397403               &    ) * r1_e1e2t(ji,jj) 
    398404 
     
    442448 
    443449            ! P/delta at F points 
    444             zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 
     450            ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility) 
     451            zp_delf = 0.25_wp * ( (zp_delt(ji,jj) + zp_delt(ji+1,jj)) + (zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1)) ) 
    445452 
    446453            ! stress at F points (zkt/=0 if landfast) 
     
    450457 
    451458         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 
     459         ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility) 
    452460         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    453461            !                   !--- U points 
    454             zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
     462            zfU(ji,jj) = 0.5_wp * ( (( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
    455463               &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
    456                &                    ) * r1_e2u(ji,jj)                                                                      & 
     464               &                    ) * r1_e2u(ji,jj))                                                                      & 
    457465               &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
    458466               &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
     
    460468            ! 
    461469            !                !--- V points 
    462             zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
     470            zfV(ji,jj) = 0.5_wp * ( (( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
    463471               &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
    464                &                    ) * r1_e1v(ji,jj)                                                                      & 
     472               &                    ) * r1_e1v(ji,jj))                                                                      & 
    465473               &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
    466474               &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
     
    468476            ! 
    469477            !                !--- ice currents at U-V point 
    470             v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) 
    471             u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) 
     478            v_iceU(ji,jj) = 0.25_wp * ( (v_ice(ji,jj) + v_ice(ji,jj-1)) + (v_ice(ji+1,jj) + v_ice(ji+1,jj-1)) ) * umask(ji,jj,1) 
     479            u_iceV(ji,jj) = 0.25_wp * ( (u_ice(ji,jj) + u_ice(ji-1,jj)) + (u_ice(ji,jj+1) + u_ice(ji-1,jj+1)) ) * vmask(ji,jj,1) 
    472480            ! 
    473481         END_2D 
     
    682690         IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice, zmsk15 ) 
    683691         ! 
     692         ! 
     693         ! --- change strength according to advected a_i and v_i (upstream for now) --- ! 
     694         IF( ll_advups .AND. ln_str_H79 ) THEN 
     695            ! 
     696            IF( jter == 1 ) THEN                               ! init 
     697               ALLOCATE( za_i_ups(jpi,jpj,jpl), zv_i_ups(jpi,jpj,jpl) ) 
     698               ALLOCATE( ztmp(jpi,jpj) ) 
     699               zdt_ups = rDt_ice / REAL( nn_nevp ) 
     700               za_i_ups(:,:,:) = a_i(:,:,:) 
     701               zv_i_ups(:,:,:) = v_i(:,:,:) 
     702            ELSE 
     703               CALL lbc_lnk( 'icedyn_rhg_evp', za_i_ups, 'T', 1.0_wp, zv_i_ups, 'T', 1.0_wp )                
     704            ENDIF 
     705            ! 
     706            CALL rhg_upstream( zdt_ups, u_ice, v_ice, za_i_ups )   ! upstream advection: a_i 
     707            CALL rhg_upstream( zdt_ups, u_ice, v_ice, zv_i_ups )   ! upstream advection: v_i 
     708            ! 
     709            DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )    ! strength 
     710               strength(ji,jj) = rn_pstar * SUM( zv_i_ups(ji,jj,:) ) * EXP( -rn_crhg * ( 1._wp - SUM( za_i_ups(ji,jj,:) ) ) ) 
     711            END_2D 
     712            IF( nn_hls == 1 )  CALL lbc_lnk( 'icedyn_rhg_evp', strength, 'T', 1.0_wp ) 
     713            ! 
     714            DO_2D( 0, 0, 0, 0 )                                ! strength smoothing 
     715               IF( SUM( za_i_ups(ji,jj,:) ) > 0._wp ) THEN 
     716                  ztmp(ji,jj) = ( 4._wp * strength(ji,jj) + strength(ji-1,jj  ) + strength(ji+1,jj  ) & 
     717                     &                                    + strength(ji  ,jj-1) + strength(ji  ,jj+1) & 
     718                     &          ) / ( 4._wp + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
     719               ELSE 
     720                  ztmp(ji,jj) = 0._wp 
     721               ENDIF 
     722            END_2D 
     723            DO_2D( 0, 0, 0, 0 ) 
     724               strength(ji,jj) = ztmp(ji,jj) 
     725            END_2D 
     726            ! 
     727            IF( jter == nn_nevp ) THEN 
     728               DEALLOCATE( za_i_ups, zv_i_ups ) 
     729               DEALLOCATE( ztmp ) 
     730            ENDIF 
     731         ENDIF 
    684732         !                                                ! ==================== ! 
    685733      END DO                                              !  end loop over jter  ! 
    686734      !                                                   ! ==================== ! 
    687735      IF( ln_aEVP )   CALL iom_put( 'beta_evp' , zbeta ) 
     736      ! 
     737      IF( ll_advups .AND. ln_str_H79 )   CALL lbc_lnk( 'icedyn_rhg_evp', strength, 'T', 1.0_wp ) 
    688738      ! 
    689739      !------------------------------------------------------------------------------! 
     
    760810      IF( iom_use('iceshe') )   CALL iom_put( 'iceshe' , pshear_i * zmsk00 )   ! shear 
    761811      IF( iom_use('icestr') )   CALL iom_put( 'icestr' , strength * zmsk00 )   ! strength 
     812      IF( iom_use('icedlt') )   CALL iom_put( 'icedlt' , pdelta_i * zmsk00 )   ! delta 
    762813 
    763814      ! --- Stress tensor invariants (SIMIP diags) --- ! 
     
    10181069   END SUBROUTINE rhg_evp_rst 
    10191070 
     1071   SUBROUTINE rhg_upstream( pdt, pu, pv, pt ) 
     1072      !!--------------------------------------------------------------------- 
     1073      !!                    ***  ROUTINE rhg_upstream  *** 
     1074      !! 
     1075      !! **  Purpose :   compute the upstream fluxes and upstream guess of tracer 
     1076      !!---------------------------------------------------------------------- 
     1077      REAL(wp)                   , INTENT(in   ) ::   pdt              ! tracer time-step 
     1078      REAL(wp), DIMENSION(:,:  ) , INTENT(in   ) ::   pu, pv           ! 2 ice velocity components 
     1079      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   pt               ! tracer fields 
     1080      ! 
     1081      INTEGER  ::   ji, jj, jl    ! dummy loop indices 
     1082      REAL(wp) ::   ztra          ! local scalar 
     1083      REAL(wp), DIMENSION(jpi,jpj) ::   zfu_ups, zfv_ups   ! upstream fluxes 
     1084      !!---------------------------------------------------------------------- 
     1085      DO jl = 1, jpl 
     1086         DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 
     1087            zfu_ups(ji,jj) = MAX( pu(ji,jj)*e2u(ji,jj), 0._wp ) * pt(ji  ,jj  ,jl) + & 
     1088               &             MIN( pu(ji,jj)*e2u(ji,jj), 0._wp ) * pt(ji+1,jj  ,jl) 
     1089            zfv_ups(ji,jj) = MAX( pv(ji,jj)*e1v(ji,jj), 0._wp ) * pt(ji  ,jj  ,jl) + & 
     1090               &             MIN( pv(ji,jj)*e1v(ji,jj), 0._wp ) * pt(ji  ,jj+1,jl) 
     1091         END_2D 
     1092         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
     1093            ztra = - ( zfu_ups(ji,jj) - zfu_ups(ji-1,jj) + zfv_ups(ji,jj) - zfv_ups(ji,jj-1) ) 
     1094            ! 
     1095            pt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     1096         END_2D 
     1097      END DO 
     1098      ! 
     1099   END SUBROUTINE rhg_upstream 
    10201100 
    10211101#else 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rhg_vp.F90

    r15127 r15349  
    218218       
    219219      !!---------------------------------------------------------------------------------------------------------------------- 
    220       ! DEBUG put all forcing terms to zero 
    221          ! air-ice drag 
    222          utau_ice(:,:) = 0._wp 
    223          vtau_ice(:,:) = 0._wp 
    224          ! coriolis 
    225          ff_t(:,:) = 0._wp 
    226          ! ice-ocean drag 
    227          rn_cio = 0._wp 
    228          ! ssh  
    229          ! done line 330 !!! dont forget to act there 
    230       ! END DEBUG 
     220!!$      ! DEBUG put all forcing terms to zero 
     221!!$         ! air-ice drag 
     222!!$         utau_ice(:,:) = 0._wp 
     223!!$         vtau_ice(:,:) = 0._wp 
     224!!$         ! coriolis 
     225!!$         ff_t(:,:) = 0._wp 
     226!!$         ! ice-ocean drag 
     227!!$         rn_cio = 0._wp 
     228!!$         ! ssh  
     229!!$         ! done line 330 !!! dont forget to act there 
     230!!$      ! END DEBUG 
    231231 
    232232      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_rhg_vp: VP sea-ice rheology (LSR solver)' 
     
    240240       
    241241      ! for diagnostics and convergence tests 
    242       DO_2D( 1, 1, 1, 1 ) 
     242      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    243243         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    244244      END_2D 
    245245      IF( nn_rhg_chkcvg > 0 ) THEN 
    246          DO_2D( 1, 1, 1, 1 ) 
     246         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    247247            zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
    248248         END_2D 
     
    329329      !    non-embedded sea ice: use ocean surface for slope calculation 
    330330      zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b) 
    331       zsshdyn(:,:) = 0._wp ! DEBUG CAREFUL !!! 
    332  
    333       zmt(:,:) = rhos * vt_s(:,:) + rhoi * vt_i(:,:)       ! Snow and ice mass at T-point 
    334       zmf(:,:) = zmt(:,:) * ff_t(:,:)                      ! Coriolis factor at T points (m*f) 
    335        
    336       DO jj = 2, jpj - 1 
    337          DO ji = 2, jpi - 1 
    338  
    339             ! Ice fraction at U-V points 
    340             za_iU(ji,jj)    = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    341             za_iV(ji,jj)    = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    342  
    343             ! Snow and ice mass at U-V points 
    344             zm1             = zmt(ji,jj) 
    345             zm2             = zmt(ji+1,jj) 
    346             zm3             = zmt(ji,jj+1) 
    347              
    348             zmassU          = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    349             zmassV          = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    350                            
    351             ! Mass per unit area divided by time step 
    352             zmassU_t(ji,jj) = zmassU * r1_Dt_ice 
    353             zmassV_t(ji,jj) = zmassV * r1_Dt_ice 
    354  
    355             ! Acceleration term contribution to RHS (depends on velocity at previous time step)             
    356             zmU_t(ji,jj)    = zmassU_t(ji,jj) * u_ice(ji,jj) 
    357             zmV_t(ji,jj)    = zmassV_t(ji,jj) * v_ice(ji,jj) 
    358              
    359             ! Ocean currents at U-V points 
    360             v_oceU(ji,jj)   = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 
    361             u_oceV(ji,jj)   = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 
    362              
    363             ! Wind stress 
    364             ztaux_ai(ji,jj) = za_iU(ji,jj) * utau_ice(ji,jj) 
    365             ztauy_ai(ji,jj) = za_iV(ji,jj) * vtau_ice(ji,jj) 
    366  
    367             ! Force due to sea surface tilt(- m*g*GRAD(ssh)) 
    368             zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
    369             zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
    370  
    371             ! Mask for ice presence (1) or absence (0) 
    372             zmsk00x(ji,jj)  = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
    373             zmsk00y(ji,jj)  = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
    374  
    375             ! Mask for lots of ice (1) or little ice (0) 
    376             IF ( zmassU <= zmmin .AND. za_iU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
    377             ELSE                                                      ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
    378             IF ( zmassV <= zmmin .AND. za_iV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
    379             ELSE                                                      ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF               
     331!!$      zsshdyn(:,:) = 0._wp ! DEBUG CAREFUL !!! 
     332 
     333      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     334         zm1          = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) )  ! Ice/snow mass at U-V points 
     335         zmf  (ji,jj) = zm1 * ff_t(ji,jj)                            ! Coriolis at T points (m*f) 
     336      END_2D 
     337       
     338      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
     339 
     340         ! Ice fraction at U-V points 
     341         za_iU(ji,jj)    = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     342         za_iV(ji,jj)    = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     343          
     344         ! Ice/snow mass at U-V points 
     345         zm1 = ( rhos * vt_s(ji  ,jj  ) + rhoi * vt_i(ji  ,jj  ) ) 
     346         zm2 = ( rhos * vt_s(ji+1,jj  ) + rhoi * vt_i(ji+1,jj  ) ) 
     347         zm3 = ( rhos * vt_s(ji  ,jj+1) + rhoi * vt_i(ji  ,jj+1) )          
     348         zmassU          = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     349         zmassV          = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     350          
     351         ! Mass per unit area divided by time step 
     352         zmassU_t(ji,jj) = zmassU * r1_Dt_ice 
     353         zmassV_t(ji,jj) = zmassV * r1_Dt_ice 
     354          
     355         ! Acceleration term contribution to RHS (depends on velocity at previous time step)             
     356         zmU_t(ji,jj)    = zmassU_t(ji,jj) * u_ice(ji,jj) 
     357         zmV_t(ji,jj)    = zmassV_t(ji,jj) * v_ice(ji,jj) 
     358          
     359         ! Ocean currents at U-V points 
     360         v_oceU(ji,jj)   = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 
     361         u_oceV(ji,jj)   = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 
     362          
     363         ! Wind stress 
     364         ztaux_ai(ji,jj) = za_iU(ji,jj) * utau_ice(ji,jj) 
     365         ztauy_ai(ji,jj) = za_iV(ji,jj) * vtau_ice(ji,jj) 
     366          
     367         ! Force due to sea surface tilt(- m*g*GRAD(ssh)) 
     368         zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
     369         zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
     370          
     371         ! Mask for ice presence (1) or absence (0) 
     372         zmsk00x(ji,jj)  = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
     373         zmsk00y(ji,jj)  = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
     374          
     375         ! Mask for lots of ice (1) or little ice (0) 
     376         IF ( zmassU <= zmmin .AND. za_iU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
     377         ELSE                                                      ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
     378         IF ( zmassV <= zmmin .AND. za_iV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
     379         ELSE                                                      ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF               
    380380 
    381381! MV TEST DEBUG 
    382             IF ( ( zmt(ji,jj)   <= zmmin .OR. zmt(ji+1,jj)  <= zmmin )     .AND.  & 
    383                & ( at_i(ji,jj)  <= zamin .OR. at_i(ji+1,jj) <= zamin ) )    THEN   ;   zmsk01x(ji,jj) = 0._wp 
    384             ELSE                                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
    385  
    386             IF ( ( zmt(ji,jj)   <= zmmin .OR. zmt(ji,jj+1)  <= zmmin )     .AND.  & 
    387                & ( at_i(ji,jj)  <= zamin .OR. at_i(ji,jj+1) <= zamin ) )    THEN   ;   zmsk01y(ji,jj) = 0._wp 
    388             ELSE                                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF               
     382!!$            IF ( ( zmt(ji,jj)   <= zmmin .OR. zmt(ji+1,jj)  <= zmmin )     .AND.  & 
     383!!$               & ( at_i(ji,jj)  <= zamin .OR. at_i(ji+1,jj) <= zamin ) )    THEN   ;   zmsk01x(ji,jj) = 0._wp 
     384!!$            ELSE                                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
     385!!$ 
     386!!$            IF ( ( zmt(ji,jj)   <= zmmin .OR. zmt(ji,jj+1)  <= zmmin )     .AND.  & 
     387!!$               & ( at_i(ji,jj)  <= zamin .OR. at_i(ji,jj+1) <= zamin ) )    THEN   ;   zmsk01y(ji,jj) = 0._wp 
     388!!$            ELSE                                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF               
    389389! END MV TEST DEBUG 
    390390 
    391          END DO 
    392       END DO    
    393  
    394       CALL iom_put( 'zmsk00x'    , zmsk00x  )   ! MV DEBUG 
    395       CALL iom_put( 'zmsk00y'    , zmsk00y  )   ! MV DEBUG 
    396       CALL iom_put( 'zmsk01x'    , zmsk01x  )   ! MV DEBUG 
    397       CALL iom_put( 'zmsk01y'    , zmsk01y  )   ! MV DEBUG 
    398       CALL iom_put( 'ztaux_ai'   , ztaux_ai )   ! MV DEBUG 
    399       CALL iom_put( 'ztauy_ai'   , ztauy_ai )   ! MV DEBUG 
    400       CALL iom_put( 'zspgU'      , zspgU    )   ! MV DEBUG 
    401       CALL iom_put( 'zspgV'      , zspgV    )   ! MV DEBUG 
    402              
     391      END_2D 
     392 
     393!!$      CALL iom_put( 'zmsk00x'    , zmsk00x  )   ! MV DEBUG 
     394!!$      CALL iom_put( 'zmsk00y'    , zmsk00y  )   ! MV DEBUG 
     395!!$      CALL iom_put( 'zmsk01x'    , zmsk01x  )   ! MV DEBUG 
     396!!$      CALL iom_put( 'zmsk01y'    , zmsk01y  )   ! MV DEBUG 
     397!!$      CALL iom_put( 'ztaux_ai'   , ztaux_ai )   ! MV DEBUG 
     398!!$      CALL iom_put( 'ztauy_ai'   , ztauy_ai )   ! MV DEBUG 
     399!!$      CALL iom_put( 'zspgU'      , zspgU    )   ! MV DEBUG 
     400!!$      CALL iom_put( 'zspgV'      , zspgV    )   ! MV DEBUG 
     401!!$             
    403402      !------------------------------------------------------------------------------! 
    404403      ! 
     
    437436 
    438437         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 
    439          DO jj = 1, jpj - 1         ! loops start at 1 since there is no boundary condition (lbc_lnk) at i=1 and j=1 for F points 
    440             DO ji = 1, jpi - 1 
    441  
    442                ! shear at F points 
    443                zds(ji,jj) = ( ( zu_c(ji,jj+1) * r1_e1u(ji,jj+1) - zu_c(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
    444                   &         + ( zv_c(ji+1,jj) * r1_e2v(ji+1,jj) - zv_c(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    445                   &         ) * r1_e1e2f(ji,jj) * fimask(ji,jj) 
    446  
    447             END DO 
    448          END DO 
     438         DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 
     439 
     440            ! shear at F points 
     441            zds(ji,jj) = ( ( zu_c(ji,jj+1) * r1_e1u(ji,jj+1) - zu_c(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
     442               &         + ( zv_c(ji+1,jj) * r1_e2v(ji+1,jj) - zv_c(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     443               &         ) * r1_e1e2f(ji,jj) * fimask(ji,jj) 
     444 
     445         END_2D 
    449446 
    450447         CALL lbc_lnk( 'icedyn_rhg_vp', zds, 'F', 1. ) ! MV TEST could be un-necessary according to Gurvan 
    451          CALL iom_put( 'zds'          , zds      )   ! MV DEBUG 
     448!!$         CALL iom_put( 'zds'          , zds      )   ! MV DEBUG 
    452449 
    453450         IF( lwp )   WRITE(numout,*) ' outer loop  1a i_out : ', i_out 
     
    496493         CALL lbc_lnk( 'icedyn_rhg_vp', zp_deltastar_t , 'T', 1. , zzt , 'T', 1., zet, 'T', 1. ) 
    497494 
    498          CALL iom_put( 'zzt'        , zzt      )   ! MV DEBUG 
    499          CALL iom_put( 'zet'        , zet      )   ! MV DEBUG 
    500          CALL iom_put( 'zp_deltastar_t', zp_deltastar_t ) ! MV DEBUG 
     495!!$         CALL iom_put( 'zzt'        , zzt      )   ! MV DEBUG 
     496!!$         CALL iom_put( 'zet'        , zet      )   ! MV DEBUG 
     497!!$         CALL iom_put( 'zp_deltastar_t', zp_deltastar_t ) ! MV DEBUG 
    501498 
    502499         IF( lwp )   WRITE(numout,*) ' outer loop  1b i_out : ', i_out 
     
    515512          
    516513         CALL lbc_lnk( 'icedyn_rhg_vp', zef, 'F', 1. ) 
    517          CALL iom_put( 'zef'          , zef            ) ! MV DEBUG 
     514!!$         CALL iom_put( 'zef'          , zef            ) ! MV DEBUG 
    518515         IF( lwp )   WRITE(numout,*) ' outer loop  1c i_out : ', i_out 
    519516 
     
    558555         CALL lbc_lnk( 'icedyn_rhg_vp', zCorU,  'U', -1., zCorV, 'V', -1. ) 
    559556 
    560          CALL iom_put( 'zCwU'          , zCwU           ) ! MV DEBUG 
    561          CALL iom_put( 'zCwV'          , zCwV           ) ! MV DEBUG 
    562          CALL iom_put( 'zCorU'         , zCorU          ) ! MV DEBUG 
    563          CALL iom_put( 'zCorV'         , zCorV          ) ! MV DEBUG 
     557!!$         CALL iom_put( 'zCwU'          , zCwU           ) ! MV DEBUG 
     558!!$         CALL iom_put( 'zCwV'          , zCwV           ) ! MV DEBUG 
     559!!$         CALL iom_put( 'zCorU'         , zCorU          ) ! MV DEBUG 
     560!!$         CALL iom_put( 'zCorV'         , zCorV          ) ! MV DEBUG 
    564561 
    565562         IF( lwp )   WRITE(numout,*) ' outer loop  1f i_out : ', i_out 
     
    591588         END DO 
    592589 
    593          CALL iom_put( 'zs1_rhsu'      , zs1_rhsu       ) ! MV DEBUG 
    594          CALL iom_put( 'zs2_rhsu'      , zs2_rhsu       ) ! MV DEBUG 
    595          CALL iom_put( 'zs1_rhsv'      , zs1_rhsv       ) ! MV DEBUG 
    596          CALL iom_put( 'zs2_rhsv'      , zs2_rhsv       ) ! MV DEBUG 
     590!!$         CALL iom_put( 'zs1_rhsu'      , zs1_rhsu       ) ! MV DEBUG 
     591!!$         CALL iom_put( 'zs2_rhsu'      , zs2_rhsu       ) ! MV DEBUG 
     592!!$         CALL iom_put( 'zs1_rhsv'      , zs1_rhsv       ) ! MV DEBUG 
     593!!$         CALL iom_put( 'zs2_rhsv'      , zs2_rhsv       ) ! MV DEBUG 
    597594          
    598595         ! a priori, no lbclnk, because rhsu is only used in the inner domain 
     
    619616         CALL lbc_lnk( 'icedyn_rhg_vp', zs12_rhsv, 'F', 1. ) 
    620617 
    621          CALL iom_put( 'zs12_rhsu'     , zs12_rhsu      ) ! MV DEBUG 
    622          CALL iom_put( 'zs12_rhsv'     , zs12_rhsv      ) ! MV DEBUG 
     618!!$         CALL iom_put( 'zs12_rhsu'     , zs12_rhsu      ) ! MV DEBUG 
     619!!$         CALL iom_put( 'zs12_rhsv'     , zs12_rhsv      ) ! MV DEBUG 
    623620 
    624621         ! a priori, no lbclnk, because rhsu are only used in the inner domain 
     
    644641         END DO 
    645642 
    646          CALL iom_put( 'zf_rhsu'       , zf_rhsu        ) ! MV DEBUG 
    647          CALL iom_put( 'zf_rhsv'       , zf_rhsv        ) ! MV DEBUG 
     643!!$         CALL iom_put( 'zf_rhsu'       , zf_rhsu        ) ! MV DEBUG 
     644!!$         CALL iom_put( 'zf_rhsv'       , zf_rhsv        ) ! MV DEBUG 
    648645          
    649646         !--------------------------- 
     
    666663         CALL lbc_lnk( 'icedyn_rhg_vp', ztaux_oi_rhsu, 'U', -1., ztauy_oi_rhsv, 'V',  -1.) 
    667664 
    668          CALL iom_put( 'zmU_t'         , zmU_t          ) ! MV DEBUG 
    669          CALL iom_put( 'zmV_t'         , zmV_t          ) ! MV DEBUG 
    670          CALL iom_put( 'ztaux_oi_rhsu' , ztaux_oi_rhsu  ) ! MV DEBUG 
    671          CALL iom_put( 'ztauy_oi_rhsv' , ztauy_oi_rhsv  ) ! MV DEBUG 
    672          CALL iom_put( 'zrhsu'         , zrhsu          ) ! MV DEBUG 
    673          CALL iom_put( 'zrhsv'         , zrhsv          ) ! MV DEBUG 
    674           
     665!!$         CALL iom_put( 'zmU_t'         , zmU_t          ) ! MV DEBUG 
     666!!$         CALL iom_put( 'zmV_t'         , zmV_t          ) ! MV DEBUG 
     667!!$         CALL iom_put( 'ztaux_oi_rhsu' , ztaux_oi_rhsu  ) ! MV DEBUG 
     668!!$         CALL iom_put( 'ztauy_oi_rhsv' , ztauy_oi_rhsv  ) ! MV DEBUG 
     669!!$         CALL iom_put( 'zrhsu'         , zrhsu          ) ! MV DEBUG 
     670!!$         CALL iom_put( 'zrhsv'         , zrhsv          ) ! MV DEBUG 
     671!!$          
    675672         ! inner domain calculations -> no lbclnk 
    676673 
     
    773770         CALL lbc_lnk( 'icedyn_rhg_vp', zEU  , 'U', 1., zEV  , 'V',  1. ) 
    774771                
    775          CALL iom_put( 'zAU'           , zAU            ) ! MV DEBUG 
    776          CALL iom_put( 'zBU'           , zBU            ) ! MV DEBUG 
    777          CALL iom_put( 'zCU'           , zCU            ) ! MV DEBUG 
    778          CALL iom_put( 'zDU'           , zDU            ) ! MV DEBUG 
    779          CALL iom_put( 'zEU'           , zEU            ) ! MV DEBUG 
    780          CALL iom_put( 'zAV'           , zAV            ) ! MV DEBUG 
    781          CALL iom_put( 'zBV'           , zBV            ) ! MV DEBUG 
    782          CALL iom_put( 'zCV'           , zCV            ) ! MV DEBUG 
    783          CALL iom_put( 'zDV'           , zDV            ) ! MV DEBUG 
    784          CALL iom_put( 'zEV'           , zEV            ) ! MV DEBUG 
     772!!$         CALL iom_put( 'zAU'           , zAU            ) ! MV DEBUG 
     773!!$         CALL iom_put( 'zBU'           , zBU            ) ! MV DEBUG 
     774!!$         CALL iom_put( 'zCU'           , zCU            ) ! MV DEBUG 
     775!!$         CALL iom_put( 'zDU'           , zDU            ) ! MV DEBUG 
     776!!$         CALL iom_put( 'zEU'           , zEU            ) ! MV DEBUG 
     777!!$         CALL iom_put( 'zAV'           , zAV            ) ! MV DEBUG 
     778!!$         CALL iom_put( 'zBV'           , zBV            ) ! MV DEBUG 
     779!!$         CALL iom_put( 'zCV'           , zCV            ) ! MV DEBUG 
     780!!$         CALL iom_put( 'zDV'           , zDV            ) ! MV DEBUG 
     781!!$         CALL iom_put( 'zEV'           , zEV            ) ! MV DEBUG 
    785782 
    786783      !------------------------------------------------------------------------------! 
     
    11031100      CALL lbc_lnk( 'icedyn_rhg_vp', zCU_prime  , 'U',  1., zCV_prime  , 'V',  1. ) 
    11041101 
    1105       CALL iom_put( 'zFU'           , zFU            ) ! MV DEBUG 
    1106       CALL iom_put( 'zBU_prime'     , zBU_prime      ) ! MV DEBUG 
    1107       CALL iom_put( 'zCU_prime'     , zCU_prime      ) ! MV DEBUG 
    1108       CALL iom_put( 'zFU_prime'     , zFU_prime      ) ! MV DEBUG 
    1109  
    1110       CALL iom_put( 'zFV'           , zFV            ) ! MV DEBUG 
    1111       CALL iom_put( 'zBV_prime'     , zBV_prime      ) ! MV DEBUG 
    1112       CALL iom_put( 'zCV_prime'     , zCV_prime      ) ! MV DEBUG 
    1113       CALL iom_put( 'zFV_prime'     , zFV_prime      ) ! MV DEBUG 
     1102!!$      CALL iom_put( 'zFU'           , zFU            ) ! MV DEBUG 
     1103!!$      CALL iom_put( 'zBU_prime'     , zBU_prime      ) ! MV DEBUG 
     1104!!$      CALL iom_put( 'zCU_prime'     , zCU_prime      ) ! MV DEBUG 
     1105!!$      CALL iom_put( 'zFU_prime'     , zFU_prime      ) ! MV DEBUG 
     1106!!$ 
     1107!!$      CALL iom_put( 'zFV'           , zFV            ) ! MV DEBUG 
     1108!!$      CALL iom_put( 'zBV_prime'     , zBV_prime      ) ! MV DEBUG 
     1109!!$      CALL iom_put( 'zCV_prime'     , zCV_prime      ) ! MV DEBUG 
     1110!!$      CALL iom_put( 'zFV_prime'     , zFV_prime      ) ! MV DEBUG 
    11141111 
    11151112      CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    11161113 
    1117       IF ( lwp ) WRITE(numout,*) ' We are about to output uice_dbg ' 
    1118       IF( iom_use('uice_dbg' ) )   CALL iom_put( 'uice_dbg'   , u_ice    )                              ! ice velocity u after solver 
    1119       IF( iom_use('vice_dbg' ) )   CALL iom_put( 'vice_dbg'   , v_ice    )                              ! ice velocity v after solver 
     1114!!$      IF ( lwp ) WRITE(numout,*) ' We are about to output uice_dbg ' 
     1115!!$      IF( iom_use('uice_dbg' ) )   CALL iom_put( 'uice_dbg'   , u_ice    )                              ! ice velocity u after solver 
     1116!!$      IF( iom_use('vice_dbg' ) )   CALL iom_put( 'vice_dbg'   , v_ice    )                              ! ice velocity v after solver 
    11201117             
    11211118      !------------------------------------------------------------------------------! 
     
    11341131      ENDIF 
    11351132 
    1136       ! MV DEBUG test - replace ice velocity by ocean current to give the model the means to go ahead 
    1137       DO jj = 2, jpj - 1 
    1138          DO ji = 2, jpi - 1    
    1139  
    1140              u_ice(ji,jj) =   zmsk00x(ji,jj)                               &  
    1141       &         * (           zmsk01x(ji,jj)   * u_oce(ji,jj) * 0.01_wp    & 
    1142                   + ( 1._wp - zmsk01x(ji,jj) ) * u_oce(ji,jj) * 0.01_wp    ) 
    1143  
    1144              v_ice(ji,jj) =   zmsk00y(ji,jj)                               &  
    1145       &         * (           zmsk01y(ji,jj)   * v_oce(ji,jj) * 0.01_wp    & 
    1146                   + ( 1._wp - zmsk01y(ji,jj) ) * v_oce(ji,jj) * 0.01_wp    ) 
    1147  
    1148          END DO 
    1149       END DO 
    1150  
    1151       CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    1152  
    1153       IF ( lwp ) WRITE(numout,*) ' Velocity replaced ' 
     1133!!$      ! MV DEBUG test - replace ice velocity by ocean current to give the model the means to go ahead 
     1134!!$      DO jj = 2, jpj - 1 
     1135!!$         DO ji = 2, jpi - 1    
     1136!!$ 
     1137!!$             u_ice(ji,jj) =   zmsk00x(ji,jj)                               &  
     1138!!$      &         * (           zmsk01x(ji,jj)   * u_oce(ji,jj) * 0.01_wp    & 
     1139!!$                  + ( 1._wp - zmsk01x(ji,jj) ) * u_oce(ji,jj) * 0.01_wp    ) 
     1140!!$ 
     1141!!$             v_ice(ji,jj) =   zmsk00y(ji,jj)                               &  
     1142!!$      &         * (           zmsk01y(ji,jj)   * v_oce(ji,jj) * 0.01_wp    & 
     1143!!$                  + ( 1._wp - zmsk01y(ji,jj) ) * v_oce(ji,jj) * 0.01_wp    ) 
     1144!!$ 
     1145!!$         END DO 
     1146!!$      END DO 
     1147!!$ 
     1148!!$      CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
     1149!!$ 
     1150!!$      IF ( lwp ) WRITE(numout,*) ' Velocity replaced ' 
    11541151 
    11551152      ! END DEBUG 
     
    13651362               zfac             =   zp_deltastar_t(ji,jj) 
    13661363               zsig1            =   zfac * ( pdivu_i(ji,jj) - zdeltastar_t(ji,jj) ) 
    1367                zsig1            = 0._wp !!! FUCKING DEBUG TEST !!! 
     1364!!$               zsig1            = 0._wp !!! FUCKING DEBUG TEST !!! 
    13681365               zsig2            =   zfac * z1_ecc2 * zten_i(ji,jj) 
    13691366               zsig12           =   zfac * z1_ecc2 * pshear_i(ji,jj) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icethd.F90

    r15127 r15349  
    2020   USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, sprecip, ln_cpl 
    2121   USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, & 
    22       &                 qml_ice, qcn_ice, qtr_ice_top 
     22      &                 qml_ice, qcn_ice, qtr_ice_top, utau_ice, vtau_ice 
    2323   USE ice1D          ! sea-ice: thermodynamics variables 
    2424   USE icethd_zdf     ! sea-ice: vertical heat diffusion 
     
    9797      REAL(wp), DIMENSION(jpi,jpj) ::   zu_io, zv_io, zfric, zvel   ! ice-ocean velocity (m/s) and frictional velocity (m2/s2) 
    9898      ! 
     99      ! for collection thickness 
     100      INTEGER  ::   iter             !   -       - 
     101      REAL(wp) ::   zvfrx, zvgx, ztaux, zf                     !   -      - 
     102      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, ztwogp   !   -      - 
     103      REAL(wp), PARAMETER ::   zcai = 1.4e-3_wp               ! ice-air drag (clem: should be dependent on coupling/forcing used) 
     104      REAL(wp), PARAMETER ::   zhicrit = 0.04_wp                                             ! frazil ice thickness 
     105      REAL(wp), PARAMETER ::   zsqcd   = 1.0_wp / SQRT( 1.3_wp * zcai )                      ! 1/SQRT(airdensity*drag) 
     106      REAL(wp), PARAMETER ::   zgamafr = 0.03_wp 
    99107      !!------------------------------------------------------------------- 
    100108      ! controls 
     
    128136               &                         ( v_ice(ji,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji,jj-1) + v_ice(ji,jj) ) ) 
    129137         END_2D 
    130       ELSE      !  if no ice dynamics => transmit directly the atmospheric stress to the ocean 
     138      ELSE      !  if no ice dynamics => transfer directly the atmospheric stress to the ocean 
    131139         DO_2D( 0, 0, 0, 0 ) 
    132140            zfric(ji,jj) = r1_rho0 * SQRT( 0.5_wp *  & 
     
    219227      ENDIF 
    220228 
     229 
     230      !---------------------------------------------------------! 
     231      ! Collection thickness of ice formed in leads and polynyas 
     232      !---------------------------------------------------------!     
     233      ! ht_i_new is the thickness of new ice formed in open water 
     234      ! ht_i_new can be either prescribed (ln_frazil=F) or computed (ln_frazil=T) 
     235      ! Frazil ice forms in open water, is transported by wind, accumulates at the edge of the consolidated ice edge 
     236      ! where it forms aggregates of a specific thickness called collection thickness. 
     237      ! 
     238      fraz_frac(:,:) = 0._wp 
     239      ! 
     240      ! Default new ice thickness 
     241      WHERE( qlead(:,:) < 0._wp ) ! cooling 
     242         ht_i_new(:,:) = rn_hinew 
     243      ELSEWHERE 
     244         ht_i_new(:,:) = 0._wp 
     245      END WHERE 
     246 
     247      IF( ln_frazil ) THEN 
     248         ztwogp  = 2._wp * rho0 / ( grav * 0.3_wp * ( rho0 - rhoi ) )  ! reduced grav 
     249         ! 
     250         DO_2D( 0, 0, 0, 0 ) 
     251            IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling 
     252               ! -- Wind stress -- ! 
     253               ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   & 
     254                  &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp 
     255               ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   & 
     256                  &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
     257               ! Square root of wind stress 
     258               ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
     259 
     260               ! -- Frazil ice velocity -- ! 
     261               rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) 
     262               zvfrx   = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) 
     263               zvfry   = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) 
     264 
     265               ! -- Pack ice velocity -- ! 
     266               zvgx    = ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp 
     267               zvgy    = ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp 
     268 
     269               ! -- Relative frazil/pack ice velocity -- ! 
     270               rswitch      = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
     271               zvrel2       = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
     272                  &               + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15_wp * 0.15_wp ) * rswitch 
     273 
     274               !!clem 
     275               fraz_frac(ji,jj) = rswitch * ( TANH( rn_Cfraz * ( SQRT(zvrel2) - rn_vfraz ) ) + 1._wp ) * 0.5_wp * rn_maxfraz 
     276               !!clem 
     277                
     278               ! -- new ice thickness (iterative loop) -- ! 
     279               ht_i_new(ji,jj) = zhicrit +   ( zhicrit + 0.1_wp )    & 
     280                  &                      / ( ( zhicrit + 0.1_wp ) * ( zhicrit + 0.1_wp ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
     281               iter = 1 
     282               DO WHILE ( iter < 20 )  
     283                  zf  = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) -   & 
     284                     &    ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2 
     285                  zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0_wp * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
     286 
     287                  ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 ) 
     288                  iter = iter + 1 
     289               END DO 
     290               ! 
     291               ! bound ht_i_new (though I don't see why it should be necessary) 
     292               ht_i_new(ji,jj) = MAX( 0.01_wp, MIN( ht_i_new(ji,jj), hi_max(jpl) ) ) 
     293               ! 
     294            ELSE 
     295               ht_i_new(ji,jj) = 0._wp 
     296            ENDIF 
     297            ! 
     298         END_2D 
     299         !  
     300         CALL lbc_lnk( 'icethd', fraz_frac, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp  ) 
     301 
     302      ENDIF 
     303 
    221304      !-------------------------------------------------------------------------------------------! 
    222305      ! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories 
     
    268351      ! 
    269352      IF ( ln_pnd .AND. ln_icedH ) & 
    270          &                    CALL ice_thd_pnd                      ! --- Melt ponds 
     353         &                    CALL ice_thd_pnd                      ! --- Melt ponds --- ! 
    271354      ! 
    272355      IF( jpl > 1  )          CALL ice_itd_rem( kt )                ! --- Transport ice between thickness categories --- ! 
     
    276359                              CALL ice_cor( kt , 2 )                ! --- Corrections --- ! 
    277360      ! 
    278       oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rDt_ice              ! ice natural aging incrementation 
     361      oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rDt_ice              ! --- Ice natural aging incrementation 
     362      ! 
     363      DO_2D( 0, 0, 0, 0 )                                           ! --- Ice velocity corrections 
     364         IF( at_i(ji,jj) == 0._wp ) THEN   ! if ice has melted 
     365            IF( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
     366            IF( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
     367            IF( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
     368            IF( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
     369         ENDIF 
     370      END_2D 
     371      CALL lbc_lnk( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 
    279372      ! 
    280373      ! convergence tests 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icethd_do.F90

    r15127 r15349  
    1717   USE phycst         ! physical constants 
    1818   USE sbc_oce , ONLY : sss_m 
    19    USE sbc_ice , ONLY : utau_ice, vtau_ice 
    2019   USE ice1D          ! sea-ice: thermodynamics variables 
    2120   USE ice            ! sea-ice: variables 
     
    3837 
    3938   !                          !!** namelist (namthd_do) ** 
    40    REAL(wp) ::   rn_hinew      ! thickness for new ice formation (m) 
    41    LOGICAL ::   ln_frazil     ! use of frazil ice collection as function of wind (T) or not (F) 
    42    REAL(wp) ::   rn_maxfraz    ! maximum portion of frazil ice collecting at the ice bottom 
    43    REAL(wp) ::   rn_vfraz      ! threshold drift speed for collection of bottom frazil ice 
    44    REAL(wp) ::   rn_Cfraz      ! squeezing coefficient for collection of bottom frazil ice 
     39   REAL(wp), PUBLIC ::   rn_hinew      ! thickness for new ice formation (m) 
     40   LOGICAL , PUBLIC ::   ln_frazil     ! use of frazil ice collection as function of wind (T) or not (F) 
     41   REAL(wp), PUBLIC ::   rn_maxfraz    ! maximum portion of frazil ice collecting at the ice bottom 
     42   REAL(wp), PUBLIC ::   rn_vfraz      ! threshold drift speed for collection of bottom frazil ice 
     43   REAL(wp), PUBLIC ::   rn_Cfraz      ! squeezing coefficient for collection of bottom frazil ice 
    4544 
    4645   !! * Substitutions 
     
    7877      !!------------------------------------------------------------------------ 
    7978      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    80       INTEGER  ::   iter             !   -       - 
    81       REAL(wp) ::   ztmelts, zfrazb, zweight, zde                               ! local scalars 
    82       REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
    83       REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
    84       ! 
     79      ! 
     80      REAL(wp) ::   ztmelts 
     81      REAL(wp) ::   zdE 
    8582      REAL(wp) ::   zQm          ! enthalpy exchanged with the ocean (J/m2, >0 towards ocean) 
    8683      REAL(wp) ::   zEi          ! sea ice specific enthalpy (J/kg) 
     
    10299      REAL(wp), DIMENSION(jpij) ::   zda_res     ! residual area in case of excessive heat budget 
    103100      REAL(wp), DIMENSION(jpij) ::   zv_frazb    ! accretion of frazil ice at the ice bottom 
    104       REAL(wp), DIMENSION(jpij) ::   zvrel_1d    ! relative ice / frazil velocity (1D vector) 
     101      REAL(wp), DIMENSION(jpij) ::   zfraz_frac_1d ! relative ice / frazil velocity (1D vector) 
    105102      ! 
    106103      REAL(wp), DIMENSION(jpij,jpl) ::   zv_b    ! old volume of ice in category jl 
     
    109106      REAL(wp), DIMENSION(jpij,nlay_i,jpl) ::   ze_i_2d !: 1-D version of e_i 
    110107      ! 
    111       REAL(wp), DIMENSION(jpi,jpj) ::   zvrel    ! relative ice / frazil velocity 
    112       ! 
    113       REAL(wp) :: zcai = 1.4e-3_wp               ! ice-air drag (clem: should be dependent on coupling/forcing used) 
    114108      !!-----------------------------------------------------------------------! 
    115109 
     
    119113      at_i(:,:) = SUM( a_i, dim=3 ) 
    120114      !------------------------------------------------------------------------------! 
    121       ! 1) Collection thickness of ice formed in leads and polynyas 
    122       !------------------------------------------------------------------------------!     
    123       ! ht_i_new is the thickness of new ice formed in open water 
    124       ! ht_i_new can be either prescribed (ln_frazil=F) or computed (ln_frazil=T) 
    125       ! Frazil ice forms in open water, is transported by wind 
    126       ! accumulates at the edge of the consolidated ice edge 
    127       ! where it forms aggregates of a specific thickness called 
    128       ! collection thickness. 
    129  
    130       zvrel(:,:) = 0._wp 
    131  
    132       ! Default new ice thickness 
    133       WHERE( qlead(:,:) < 0._wp ) ! cooling 
    134          ht_i_new(:,:) = rn_hinew 
    135       ELSEWHERE 
    136          ht_i_new(:,:) = 0._wp 
    137       END WHERE 
    138  
    139       IF( ln_frazil ) THEN 
    140          ! 
    141          ht_i_new(:,:) = 0._wp 
    142          ! 
    143          ! Physical constants 
    144          zhicrit = 0.04                                          ! frazil ice thickness 
    145          ztwogp  = 2. * rho0 / ( grav * 0.3 * ( rho0 - rhoi ) )  ! reduced grav 
    146          zsqcd   = 1.0 / SQRT( 1.3 * zcai )                      ! 1/SQRT(airdensity*drag) 
    147          zgamafr = 0.03 
    148          ! 
    149          DO_2D( 0, 0, 0, 0 ) 
    150             IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling 
    151                ! -- Wind stress -- ! 
    152                ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   & 
    153                   &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp 
    154                ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   & 
    155                   &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    156                ! Square root of wind stress 
    157                ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
    158  
    159                ! -- Frazil ice velocity -- ! 
    160                rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) 
    161                zvfrx   = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) 
    162                zvfry   = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) 
    163  
    164                ! -- Pack ice velocity -- ! 
    165                zvgx    = ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp 
    166                zvgy    = ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp 
    167  
    168                ! -- Relative frazil/pack ice velocity -- ! 
    169                rswitch      = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
    170                zvrel2       = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    171                   &               + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) * rswitch 
    172                zvrel(ji,jj) = SQRT( zvrel2 ) 
    173  
    174                ! -- new ice thickness (iterative loop) -- ! 
    175                ht_i_new(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
    176                   &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    177  
    178                iter = 1 
    179                DO WHILE ( iter < 20 )  
    180                   zf  = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) -   & 
    181                      &    ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2 
    182                   zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0 * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
    183  
    184                   ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 ) 
    185                   iter = iter + 1 
    186                END DO 
    187                ! 
    188                ! bound ht_i_new (though I don't see why it should be necessary) 
    189                ht_i_new(ji,jj) = MAX( 0.01_wp, MIN( ht_i_new(ji,jj), hi_max(jpl) ) ) 
    190                ! 
    191             ENDIF 
    192             ! 
    193          END_2D 
    194          !  
    195          CALL lbc_lnk( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp  ) 
    196  
    197       ENDIF 
    198  
    199       !------------------------------------------------------------------------------! 
    200       ! 2) Compute thickness, salinity, enthalpy, age, area and volume of new ice 
     115      ! 1) Compute thickness, salinity, enthalpy, age, area and volume of new ice 
    201116      !------------------------------------------------------------------------------! 
    202117      ! it occurs if cooling 
     
    223138            END DO 
    224139         END DO 
    225          CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d  (1:npti) , qlead      ) 
    226          CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d   (1:npti) , t_bo       ) 
    227          CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d(1:npti) , sfx_opw    ) 
    228          CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d(1:npti) , wfx_opw    ) 
    229          CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice (1:npti) , ht_i_new   ) 
    230          CALL tab_2d_1d( npti, nptidx(1:npti), zvrel_1d  (1:npti) , zvrel      ) 
     140         CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d     (1:npti) , qlead      ) 
     141         CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d      (1:npti) , t_bo       ) 
     142         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d   (1:npti) , sfx_opw    ) 
     143         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d   (1:npti) , wfx_opw    ) 
     144         CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice    (1:npti) , ht_i_new   ) 
     145         CALL tab_2d_1d( npti, nptidx(1:npti), zfraz_frac_1d(1:npti) , fraz_frac  ) 
    231146 
    232147         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d(1:npti) , hfx_thd    ) 
     
    300215         END DO 
    301216          
    302          zv_frazb(1:npti) = 0._wp 
    303          IF( ln_frazil ) THEN 
    304             ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    305             DO ji = 1, npti 
    306                rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) ) 
    307                zfrazb        = rswitch * ( TANH( rn_Cfraz * ( zvrel_1d(ji) - rn_vfraz ) ) + 1.0 ) * 0.5 * rn_maxfraz 
    308                zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    309                zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    310             END DO 
    311          END IF 
     217         ! A fraction fraz_frac of frazil ice is accreted at the ice bottom 
     218         DO ji = 1, npti 
     219            rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) ) 
     220            zv_frazb(ji)  =           zfraz_frac_1d(ji) * rswitch   * zv_newice(ji) 
     221            zv_newice(ji) = ( 1._wp - zfraz_frac_1d(ji) * rswitch ) * zv_newice(ji) 
     222         END DO 
    312223          
    313224         ! --- Area of new ice --- ! 
     
    317228 
    318229         !------------------------------------------------------------------------------! 
    319          ! 3) Redistribute new ice area and volume into ice categories                  ! 
     230         ! 2) Redistribute new ice area and volume into ice categories                  ! 
    320231         !------------------------------------------------------------------------------! 
    321232 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icethd_pnd.F90

    r15127 r15349  
    662662                     IF ( t_su(ji,jj,jl) > zTp ) THEN 
    663663 
    664                         zdvice = MIN( dh_i_sum_2d(ji,jj,jl)*a_ip(ji,jj,jl), v_il(ji,jj,jl) ) 
     664                        zdvice = MIN( -dh_i_sum_2d(ji,jj,jl)*a_ip(ji,jj,jl), v_il(ji,jj,jl) ) 
    665665 
    666666                        IF ( zdvice > epsi10 ) THEN 
     
    775775               ! recalculate equivalent pond variables 
    776776               IF ( a_ip(ji,jj,jl) > epsi10) THEN 
    777                   h_ip(ji,jj,jl)      = v_ip(ji,jj,jl) / a_i(ji,jj,jl) 
     777                  h_ip(ji,jj,jl)      = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) 
    778778                  a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i(ji,jj,jl) ! MV in principle, useless as computed in icevar 
    779779                  h_il(ji,jj,jl) = v_il(ji,jj,jl) / a_ip(ji,jj,jl) ! MV in principle, useless as computed in icevar 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_oce_sponge.F90

    r15127 r15349  
    688688            END DO 
    689689 
    690             ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 
     690            ubdiff(i1:i2,j1:j2,1:jpk) = (uu(i1:i2,j1:j2,1:jpk,Kbb_a) - tabres_child(i1:i2,j1:j2,1:jpk))*umask(i1:i2,j1:j2,1:jpk) 
    691691         ELSE 
    692692 
    693             ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 
     693            ubdiff(i1:i2,j1:j2,1:jpk) = (uu(i1:i2,j1:j2,1:jpk,Kbb_a) - tabres(i1:i2,j1:j2,1:jpk,1))*umask(i1:i2,j1:j2,1:jpk) 
    694694   
    695695         ENDIF 
     
    872872            END DO 
    873873 
    874             vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,: 
     874            vbdiff(i1:i2,j1:j2,1:jpk) = (vv(i1:i2,j1:j2,1:jpk,Kbb_a) - tabres_child(i1:i2,j1:j2,1:jpk))*vmask(i1:i2,j1:j2,1:jpk 
    875875         ELSE 
    876876 
    877             vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 
     877            vbdiff(i1:i2,j1:j2,1:jpk) = (vv(i1:i2,j1:j2,1:jpk,Kbb_a) - tabres(i1:i2,j1:j2,1:jpk,1))*vmask(i1:i2,j1:j2,1:jpk) 
    878878 
    879879         ENDIF 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_oce_update.F90

    r15127 r15349  
    135135      IF (Agrif_Root()) RETURN 
    136136      ! 
    137       Agrif_UseSpecialValueInUpdate = .TRUE. 
     137      l_vremap = ln_vert_remap 
     138      Agrif_UseSpecialValueInUpdate = .NOT.l_vremap  
    138139      Agrif_SpecialValueFineGrid = 0._wp 
    139140# if ! defined DECAL_FEEDBACK_2D 
     
    144145      ! 
    145146      Agrif_UseSpecialValueInUpdate = .FALSE. 
     147      l_vremap = .FALSE. 
    146148      ! 
    147149#  if defined VOL_REFLUX 
     
    173175      !        
    174176      Agrif_UseSpecialValueInUpdate = .TRUE. 
    175       Agrif_SpecialValueFineGrid = 0. 
     177      Agrif_SpecialValueFineGrid = 0._wp 
    176178 
    177179      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     
    199201      ! 
    200202#else 
    201       Agrif_UseSpecialValueInUpdate = .TRUE. 
    202       Agrif_SpecialValueFineGrid = 0. 
     203      Agrif_UseSpecialValueInUpdate = .FALSE. 
     204      Agrif_SpecialValueFineGrid = 0._wp 
    203205      !  
    204206      ! No interface separation here, update vertical grid at T points  
     
    271273         ! Update total depths: 
    272274         ! -------------------- 
    273       hu(:,:,Kmm_a) = 0._wp                        ! Ocean depth at U-points 
    274       hv(:,:,Kmm_a) = 0._wp                        ! Ocean depth at V-points 
     275      hu(:,:,Kmm_a) = 0._wp                    ! Ocean depth at U-points 
     276      hv(:,:,Kmm_a) = 0._wp                    ! Ocean depth at V-points 
    275277      DO jk = 1, jpkm1 
    276278         hu(:,:,Kmm_a) = hu(:,:,Kmm_a) + e3u(:,:,jk,Kmm_a) * umask(:,:,jk) 
     
    546548 
    547549         ELSE 
    548             DO jk=1,jpk 
     550            DO jk=k1,k2 
    549551               DO jj=j1,j2 
    550552                  DO ji=i1,i2 
     
    657659                  N_out = 0 
    658660                  DO jk=1,jpk 
    659                      IF (vmask(ji,jj,jk) == 0) EXIT 
     661                     IF (vmask(ji,jj,jk) == 0._wp) EXIT 
    660662                     N_out = N_out + 1 
    661663                     h_out(N_out) = e3v(ji,jj,jk,Kmm_a) 
     
    693695 
    694696         ELSE 
    695             DO jk=1,jpk 
     697            DO jk=k1,k2 
    696698               DO jj=j1,j2 
    697699                  DO ji=i1,i2 
     
    10971099            DO jj=j1,j2 
    10981100               DO ji=i1,i2 
    1099                   IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     1101                  IF( tabres(ji,jj,jk,1) .NE. 0._wp ) THEN  
    11001102                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    11011103                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     
    12261228                     &                                        ( e3t(ji,jj,jk  ,Kbb_a) - e3t_0(ji,jj,jk  ) ) 
    12271229                     gdepw(ji,jj,jk,Kbb_a) = gdepw(ji,jj,jk-1,Kbb_a) + e3t(ji,jj,jk-1,Kbb_a) 
    1228                      gdept(ji,jj,jk,Kbb_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kbb_a) + 0.5 * e3w(ji,jj,jk,Kbb_a))  & 
     1230                     gdept(ji,jj,jk,Kbb_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kbb_a) + 0.5_wp * e3w(ji,jj,jk,Kbb_a))  & 
    12291231                         &               + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb_a) +       e3w(ji,jj,jk,Kbb_a))  
    12301232                  END DO 
     
    12591261               &                                  +            0.5_wp * tmask(ji,jj,jk)   * ( e3t(ji,jj,jk  ,Kmm_a) - e3t_0(ji,jj,jk  ) ) 
    12601262               gdepw(ji,jj,jk,Kmm_a) = gdepw(ji,jj,jk-1,Kmm_a) + e3t(ji,jj,jk-1,Kmm_a) 
    1261                gdept(ji,jj,jk,Kmm_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kmm_a) + 0.5 * e3w(ji,jj,jk,Kmm_a))  & 
     1263               gdept(ji,jj,jk,Kmm_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kmm_a) + 0.5_wp * e3w(ji,jj,jk,Kmm_a))  & 
    12621264                   &               + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm_a) +       e3w(ji,jj,jk,Kmm_a))  
    12631265               gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm_a) - (ht(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_top_update.F90

    r14148 r15349  
    120120                  N_out = 0 
    121121                  DO jk=1,jpk ! jpk of parent grid 
    122                      IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 
     122                     IF (tmask(ji,jj,jk) == 0._wp ) EXIT ! TODO: Will not work with ISF 
    123123                     N_out = N_out + 1 
    124124                     h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_user.F90

    r15127 r15349  
    434434      ! 1. Declaration of the type of variable which have to be interpolated 
    435435      !--------------------------------------------------------------------- 
    436       ind1 =              nbghostcells 
     436      ind1 =              nbghostcells - 1 ! Remove one land cell in ghosts  
    437437      ind2 = nn_hls + 1 + nbghostcells_x_w 
    438438      ind3 = nn_hls + 1 + nbghostcells_y_s 
     
    634634      !                            2,2 = two ghost lines 
    635635      !------------------------------------------------------------------------------------- 
    636       ind1 =              nbghostcells 
     636      ind1 =              nbghostcells - 1 ! Remove one land cell in ghosts  
    637637      ind2 = nn_hls + 1 + nbghostcells_x_w 
    638638      ind3 = nn_hls + 1 + nbghostcells_y_s 
     
    661661      ! 3. Set location of interpolations 
    662662      !---------------------------------- 
    663       CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 
    664       CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1/)) 
    665       CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1/)) 
    666  
    667       CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/)) 
    668       CALL Agrif_Set_bc(u_iceini_id  ,(/0,ind1/)) 
    669       CALL Agrif_Set_bc(v_iceini_id  ,(/0,ind1/)) 
     663      CALL Agrif_Set_bc(tra_ice_id,(/0,ind1-1/)) 
     664      CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1-1/)) 
     665      CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1-1/)) 
     666 
     667      CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1-1/)) 
     668      CALL Agrif_Set_bc(u_iceini_id  ,(/0,ind1-1/)) 
     669      CALL Agrif_Set_bc(v_iceini_id  ,(/0,ind1-1/)) 
    670670 
    671671      ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) 
     
    782782      ! 1. Declaration of the type of variable which have to be interpolated 
    783783      !--------------------------------------------------------------------- 
    784       ind1 =              nbghostcells 
     784      ind1 =              nbghostcells - 1 ! Remove one land cell in ghosts  
    785785      ind2 = nn_hls + 1 + nbghostcells_x_w 
    786786      ind3 = nn_hls + 1 + nbghostcells_y_s 
     
    838838      ! 
    839839      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     840      INTEGER  ::   imin, imax, jmin, jmax 
    840841      NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 
    841842                       & ln_spc_dyn, ln_vert_remap, ln_chk_bathy 
    842843      !!-------------------------------------------------------------------------------------- 
    843844      ! 
    844       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     845      IF ( .NOT.Agrif_Root() ) THEN 
     846         ! 
     847         READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    845848901 IF( ios /= 0 )   CALL ctl_nam ( ios , 'namagrif in reference namelist' ) 
    846       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     849         READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    847850902 IF( ios >  0 )   CALL ctl_nam ( ios , 'namagrif in configuration namelist' ) 
    848       IF(lwm) WRITE ( numond, namagrif ) 
    849       ! 
    850       IF(lwp) THEN                    ! control print 
    851          WRITE(numout,*) 
    852          WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
    853          WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    854          WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
    855          WRITE(numout,*) '      Two way nesting activated ln_agrif_2way         = ', ln_agrif_2way 
    856          WRITE(numout,*) '      child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar 
    857          WRITE(numout,*) '      ad. sponge coeft for tracers      rn_sponge_tra = ', rn_sponge_tra 
    858          WRITE(numout,*) '      ad. sponge coeft for dynamics     rn_sponge_tra = ', rn_sponge_dyn 
    859          WRITE(numout,*) '      ad. time relaxation for tracers   rn_trelax_tra = ', rn_trelax_tra 
    860          WRITE(numout,*) '      ad. time relaxation for dynamics  rn_trelax_dyn = ', rn_trelax_dyn 
    861          WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
    862          WRITE(numout,*) '      vertical remapping                ln_vert_remap = ', ln_vert_remap 
    863          WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    864       ENDIF 
    865  
    866 ! JC => side effects of lines below to be checked: 
    867       IF (.not.agrif_root()) THEN 
    868          nbghostcells_x_w = nbghostcells 
    869          nbghostcells_x_e = nbghostcells 
    870          nbghostcells_y_s = nbghostcells 
    871          nbghostcells_y_n = nbghostcells 
    872   
    873  
    874          lk_west  = .TRUE. 
    875          lk_east  = .TRUE. 
    876          lk_south = .TRUE. 
    877          lk_north = .TRUE. 
     851         IF(lwm) WRITE ( numond, namagrif ) 
    878852         ! 
    879          ! Correct number of ghost cells according to periodicity 
    880          ! 
    881          IF( l_Iperio         ) THEN ; lk_west  = .FALSE. ; lk_east = .FALSE. ; nbghostcells_x_w = 0 ; nbghostcells_x_e = 0 ; ENDIF 
    882          IF( l_NFold          ) THEN  
    883             lk_west   = .FALSE. ; lk_east  = .FALSE. ; nbghostcells_x_w = 0 ; nbghostcells_x_e = 0  
    884             lk_north  = .FALSE. ; lk_south = .FALSE. ; nbghostcells_y_s = 0 ; nbghostcells_y_n = 0  
    885          ENDIF 
    886          IF( Agrif_Iy() == 1  ) THEN ; lk_south = .FALSE. ; nbghostcells_y_s = 1 ; ENDIF 
    887          IF( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() ==  Agrif_Parent(Nj0glo) - 1 ) THEN ; lk_north = .FALSE. ; nbghostcells_y_n = 1 ; ENDIF 
    888          IF( Agrif_Ix() == 1  ) THEN ; lk_west  = .FALSE. ; nbghostcells_x_w = 1 ; ENDIF 
    889          IF( Agrif_Ix() + nbcellsx/AGRIF_Irhox() ==  Agrif_Parent(Ni0glo) - 1 ) THEN ; lk_east  = .FALSE. ; nbghostcells_x_e = 1 ; ENDIF 
    890          ! 
    891          ! Some checks 
    892          IF( (.NOT.ln_vert_remap).AND.(jpkglo>Agrif_Parent(jpkglo)) )                    CALL ctl_stop( 'STOP',    & 
    893            &   'agrif_nemo_init: Agrif children must have less or equal number of vertical levels without ln_vert_remap defined' )  
    894          IF( Ni0glo /= nbcellsx + nbghostcells_x_w + nbghostcells_x_e   )   CALL ctl_stop( 'STOP',    & 
    895            &   'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + nbghostcells_x_w + nbghostcells_x_e' ) 
    896          IF( Nj0glo /= nbcellsy + nbghostcells_y_s + nbghostcells_y_n )   CALL ctl_stop( 'STOP',    & 
    897            &   'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + nbghostcells_y_s + nbghostcells_y_n' ) 
    898          IF( ln_use_jattr )   CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' ) 
    899       ELSE 
    900          ! Root grid 
    901          nbghostcells_x_w = 1  
    902          nbghostcells_x_e = 1  
    903          nbghostcells_y_s = 1  
    904          nbghostcells_y_n = 1  
    905          IF ( l_Iperio.OR.l_NFold ) THEN 
    906            nbghostcells_x_w = 0 
    907            nbghostcells_x_e = 0 
    908          ENDIF 
    909          IF ( l_NFold ) THEN 
    910            nbghostcells_y_n = 0 ! for completeness 
    911          ENDIF 
    912       ENDIF 
     853         IF(lwp) THEN                    ! control print 
     854            WRITE(numout,*) 
     855            WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
     856            WRITE(numout,*) '~~~~~~~~~~~~~~~' 
     857            WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
     858            WRITE(numout,*) '      Two way nesting activated ln_agrif_2way         = ', ln_agrif_2way 
     859            WRITE(numout,*) '      child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar 
     860            WRITE(numout,*) '      ad. sponge coeft for tracers      rn_sponge_tra = ', rn_sponge_tra 
     861            WRITE(numout,*) '      ad. sponge coeft for dynamics     rn_sponge_tra = ', rn_sponge_dyn 
     862            WRITE(numout,*) '      ad. time relaxation for tracers   rn_trelax_tra = ', rn_trelax_tra 
     863            WRITE(numout,*) '      ad. time relaxation for dynamics  rn_trelax_dyn = ', rn_trelax_dyn 
     864            WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     865            WRITE(numout,*) '      vertical remapping                ln_vert_remap = ', ln_vert_remap 
     866            WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
     867         ENDIF 
     868 
     869         imin = Agrif_Ix() 
     870         imax = Agrif_Ix() + nbcellsx/AGRIF_Irhox() 
     871         jmin = Agrif_Iy() 
     872         jmax = Agrif_Iy() + nbcellsy/AGRIF_Irhoy() 
     873         lk_west  = .TRUE. ; lk_east  = .TRUE. 
     874         lk_north = .TRUE. ; lk_south = .TRUE. 
     875 
     876         ! Check zoom position along i: 
     877         ! ---------------------------- 
     878         IF ( imin >= imax ) THEN 
     879            CALL ctl_stop( 'STOP', 'AGRIF zoom imin must be < imax' ) 
     880         ENDIF 
     881 
     882         IF ( Agrif_Parent(l_Iperio) ) THEN 
     883            IF ( l_Iperio ) THEN ! Cyclic east-west zoom 
     884               lk_west = .FALSE. ; lk_east = .FALSE. 
     885               ! Checks: 
     886               IF ( imin/=1-Agrif_Parent(nbghostcells_x_w) ) THEN 
     887                  WRITE(ctmp1, 9000) ' AGRIF zoom is East-West cyclic, imin must = ', & 
     888                  1 - Agrif_Parent(nbghostcells_x_w) 
     889                  CALL ctl_stop( 'STOP', ctmp1 ) 
     890               ENDIF 
     891               IF ( imax/=Agrif_Parent(Ni0glo)+1-Agrif_Parent(nbghostcells_x_w)) THEN 
     892                  WRITE(ctmp1, 9000) ' AGRIF zoom is East-West cyclic, imax must = ', & 
     893                  Agrif_Parent(Ni0glo) + 1 - Agrif_Parent(nbghostcells_x_w) 
     894                  CALL ctl_stop( 'STOP', ctmp1 ) 
     895               ENDIF 
     896            ELSE 
     897               IF ( imax>Agrif_Parent(Ni0glo)-Agrif_Parent(nbghostcells_x_w)) THEN 
     898                  WRITE(ctmp1, 9000) ' AGRIF zoom imax must be <= ', & 
     899                  Agrif_Parent(Ni0glo) - Agrif_Parent(nbghostcells_x_w) 
     900                  CALL ctl_stop( 'STOP', ctmp1 ) 
     901               ENDIF 
     902            ENDIF 
     903         ELSE 
     904            IF ( imin<2-Agrif_Parent(nbghostcells_x_w) ) THEN 
     905               WRITE(ctmp1, 9000) ' AGRIF zoom imin must be >= ', & 
     906               2 - Agrif_Parent(nbghostcells_x_w) 
     907               CALL ctl_stop( 'STOP', ctmp1 ) 
     908            ENDIF 
     909            IF ( imax>Agrif_Parent(Ni0glo)-Agrif_Parent(nbghostcells_x_w)) THEN 
     910               WRITE(ctmp1, 9000) ' AGRIF zoom imax must be <= ', & 
     911               Agrif_Parent(Ni0glo) - Agrif_Parent(nbghostcells_x_w) 
     912               CALL ctl_stop( 'STOP', ctmp1 ) 
     913            ENDIF 
     914            IF ( imin==2-Agrif_Parent(nbghostcells_x_w) )                    lk_west = .FALSE. 
     915            IF ( imax==Agrif_Parent(Ni0glo)-Agrif_Parent(nbghostcells_x_w) ) lk_east = .FALSE.   
     916         ENDIF 
     917 
     918         ! Check zoom position along j: 
     919         ! ---------------------------- 
     920         IF ( jmin >= jmax ) THEN 
     921            CALL ctl_stop( 'STOP', 'AGRIF zoom jmin must be < jmax' ) 
     922         ENDIF 
     923 
     924         IF ( Agrif_Parent(l_NFold) ) THEN 
     925            IF ( l_NFold ) THEN ! North-Fold  
     926               lk_north = .FALSE. 
     927               ! Checks: 
     928               IF ( jmax/=Agrif_Parent(Nj0glo)+1-Agrif_Parent(nbghostcells_y_s)) THEN  
     929                  WRITE(ctmp1, 9000) ' AGRIF zoom has a North-Fold, jmax must = ', & 
     930                  Agrif_Parent(Nj0glo) + 1 - Agrif_Parent(nbghostcells_y_s) 
     931                  CALL ctl_stop( 'STOP', ctmp1 ) 
     932               ENDIF 
     933            ENDIF 
     934         ELSE 
     935            IF ( jmax>Agrif_Parent(Nj0glo)-Agrif_Parent(nbghostcells_y_s)) THEN  
     936               WRITE(ctmp1, 9000) ' AGRIF zoom jmax must be <= ', & 
     937               Agrif_Parent(Nj0glo) - Agrif_Parent(nbghostcells_y_s) 
     938               CALL ctl_stop( 'STOP', ctmp1 ) 
     939            ENDIF 
     940            IF ( jmax==Agrif_Parent(Nj0glo)-Agrif_Parent(nbghostcells_y_s) ) lk_north = .FALSE.  
     941         ENDIF 
     942 
     943         IF ( jmin<2-Agrif_Parent(nbghostcells_y_s)) THEN  
     944            WRITE(ctmp1, 9000) ' AGRIF zoom jmin must be >= ', & 
     945            2 - Agrif_Parent(nbghostcells_y_s) 
     946            CALL ctl_stop( 'STOP', ctmp1 ) 
     947         ENDIF 
     948         IF ( jmin==2-Agrif_Parent(nbghostcells_y_s) ) lk_south = .FALSE.  
     949 
     950      ELSE ! Root grid 
     951         lk_west  = .FALSE. ; lk_east  = .FALSE. 
     952         lk_north = .FALSE. ; lk_south = .FALSE. 
     953      ENDIF 
     954   
     955      ! Set ghost cells including over Parent grid:  
     956      nbghostcells_x_w = nbghostcells 
     957      nbghostcells_x_e = nbghostcells 
     958      nbghostcells_y_s = nbghostcells 
     959      nbghostcells_y_n = nbghostcells 
     960 
     961      IF (.NOT.lk_west ) nbghostcells_x_w = 1 
     962      IF (.NOT.lk_east ) nbghostcells_x_e = 1 
     963      IF (.NOT.lk_south) nbghostcells_y_s = 1 
     964      IF (.NOT.lk_north) nbghostcells_y_n = 1 
     965 
     966      IF ( l_Iperio ) THEN 
     967         nbghostcells_x_w = 0 ; nbghostcells_x_e = 0 
     968      ENDIF 
     969      IF ( l_NFold ) THEN 
     970         nbghostcells_y_n = 0 
     971      ENDIF 
     972       
     973      IF ( .NOT.Agrif_Root() ) THEN ! Check expected grid size:  
     974         IF( (.NOT.ln_vert_remap).AND.(jpkglo>Agrif_Parent(jpkglo)) )   CALL ctl_stop( 'STOP',    & 
     975           &   'AGRIF children must have less or equal number of vertical levels without ln_vert_remap defined' )  
     976         IF( Ni0glo /= nbcellsx + nbghostcells_x_w + nbghostcells_x_e ) CALL ctl_stop( 'STOP',    & 
     977           &   'AGRIF children requires jpiglo == nbcellsx + nbghostcells_x_w + nbghostcells_x_e' ) 
     978         IF( Nj0glo /= nbcellsy + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP',    & 
     979           &   'AGRIF children requires jpjglo == nbcellsy + nbghostcells_y_s + nbghostcells_y_n' ) 
     980         IF( ln_use_jattr )   CALL ctl_stop( 'STOP', 'AGRIF children requires ln_use_jattr = .false. ' ) 
     981 
     982         IF(lwp) THEN                     ! Control print 
     983            WRITE(numout,*) 
     984            WRITE(numout,*) 'AGRIF boundaries and ghost cells:' 
     985            WRITE(numout,*) 'lk_west' , lk_west 
     986            WRITE(numout,*) 'lk_east' , lk_east 
     987            WRITE(numout,*) 'lk_south', lk_south 
     988            WRITE(numout,*) 'lk_north', lk_north 
     989            WRITE(numout,*) 'nbghostcells_y_s', nbghostcells_y_s 
     990            WRITE(numout,*) 'nbghostcells_y_n', nbghostcells_y_n 
     991            WRITE(numout,*) 'nbghostcells_x_w', nbghostcells_x_w 
     992            WRITE(numout,*) 'nbghostcells_x_e', nbghostcells_x_e 
     993         ENDIF 
     994      ENDIF 
     995 
     9969000  FORMAT (a, i4) 
    913997      ! 
    914998      ! 
     
    11061190           
    11071191            bounds_chunks(1,1,1,1) = bounds(1,1,2) 
    1108             bounds_chunks(1,1,2,1) = nn_hls+1 
     1192            bounds_chunks(1,1,2,1) = nn_hls+1  
    11091193        
    11101194            bounds_chunks(2,1,1,2) = nn_hls+1  
     
    11611245      IF( isens == 1 ) THEN 
    11621246         IF( ptx == 2 ) THEN ! T, V points 
    1163             agrif_external_switch_index = jpiglo-i1+2*nn_hls 
     1247            agrif_external_switch_index = jpiglo-i1+2 
    11641248         ELSE ! U, F points 
    1165             agrif_external_switch_index = jpiglo-i1+2*nn_hls-1       
     1249            agrif_external_switch_index = jpiglo-i1+1  
    11661250         ENDIF 
    11671251      ELSE IF( isens ==2 ) THEN 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdydyn2d.F90

    r14448 r15349  
    9292               llrecv2(2)   = llrecv2(2)   .OR. lrecv_bdyext(ib_bdy,2,2,ir)     ! might search point towards bdy on the east 
    9393               llsend3(3:4) = llsend3(3:4) .OR. lsend_bdyint(ib_bdy,3,3:4,ir)   ! north/south, V points 
    94                llsend3(3)   = llsend3(3)   .OR. lsend_bdyext(ib_bdy,3,3,ir)     ! neighbour might search point towards its north bdy  
     94               llsend3(3)   = llsend3(3)   .OR. lsend_bdyext(ib_bdy,3,3,ir)     ! neighbour might search point towards its north bdy 
    9595               llrecv3(3:4) = llrecv3(3:4) .OR. lrecv_bdyint(ib_bdy,3,3:4,ir)   ! north/south, V points 
    9696               llrecv3(4)   = llrecv3(4)   .OR. lrecv_bdyext(ib_bdy,3,4,ir)     ! might search point towards bdy on the north 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdyini.F90

    r15127 r15349  
    549549                     ! 
    550550                     icount = icount  + 1 
    551                      idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1   ! global to local indexes 
    552                      idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1   ! global to local indexes 
     551                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy) - mig(1) + 1   ! global to local indexes 
     552                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy) - mjg(1) + 1   ! global to local indexes 
    553553                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy) 
    554554                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 
     
    577577               ! check if point has to be sent     to   a neighbour 
    578578               ! W neighbour and on the inner left  side 
    579                IF( ii == 2    .AND. mpiSnei(nn_hls,jpwe) > -1 )   lsend_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     579               IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. mpiSnei(nn_hls,jpwe) > -1 )   lsend_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    580580               ! E neighbour and on the inner right side 
    581                IF( ii == jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 )   lsend_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
     581               IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. mpiSnei(nn_hls,jpea) > -1 )   lsend_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
    582582               ! S neighbour and on the inner down side 
    583                IF( ij == 2    .AND. mpiSnei(nn_hls,jpso) > -1 )   lsend_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
     583               IF( ij >= Njs0 .AND. ij < Njs0 + nn_hls .AND. mpiSnei(nn_hls,jpso) > -1 )   lsend_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
    584584               ! N neighbour and on the inner up   side 
    585                IF( ij == jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 )   lsend_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
     585               IF( ij <= Nje0 .AND. ij > Nje0 - nn_hls .AND. mpiSnei(nn_hls,jpno) > -1 )   lsend_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
    586586               ! 
    587587               ! check if point has to be received from a neighbour 
    588588               ! W neighbour and on the outter left  side 
    589                IF( ii == 1     .AND. mpiRnei(nn_hls,jpwe) > -1 )   lrecv_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     589               IF( ii  < Nis0                          .AND. mpiRnei(nn_hls,jpwe) > -1 )   lrecv_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    590590               ! E neighbour and on the outter right side 
    591                IF( ii == jpi   .AND. mpiRnei(nn_hls,jpea) > -1 )   lrecv_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
     591               IF( ii  > Nie0                          .AND. mpiRnei(nn_hls,jpea) > -1 )   lrecv_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
    592592               ! S neighbour and on the outter down side 
    593                IF( ij == 1     .AND. mpiRnei(nn_hls,jpso) > -1 )   lrecv_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
     593               IF( ij  < Njs0                          .AND. mpiRnei(nn_hls,jpso) > -1 )   lrecv_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
    594594               ! N neighbour and on the outter up   side 
    595                IF( ij == jpj   .AND. mpiRnei(nn_hls,jpno) > -1 )   lrecv_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
     595               IF( ij  > Nje0                          .AND. mpiRnei(nn_hls,jpno) > -1 )   lrecv_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
    596596               ! 
    597597            END DO 
     
    642642      ! Read global 2D mask at T-points: bdytmask 
    643643      ! ----------------------------------------- 
    644       ! bdytmask = 1  on the computational domain AND on open boundaries 
     644      ! bdytmask = 1  on the computational domain but not on open boundaries 
    645645      !          = 0  elsewhere    
    646646 
     
    732732               ! 
    733733               ! search neighbour in the  west/east  direction 
    734                ! Rim is on the halo and computed ocean is towards exterior of mpi domain   
     734               ! 
     735               ! Rim is on the halo and computed ocean is towards exterior of mpi domain : 
    735736               !      <--    (o exterior)     -->   
    736737               ! (1)  o|x         OR    (2)   x|o 
    737738               !       |___                 ___| 
     739               ! ==> cannot compute the point x -> need to receive it 
    738740               IF( iibi==0     .OR. ii1==0     .OR. ii2==0     .OR. ii3==0     )   lrecv_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     741               IF( iibe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    739742               IF( iibi==jpi+1 .OR. ii1==jpi+1 .OR. ii2==jpi+1 .OR. ii3==jpi+1 )   lrecv_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE.   
    740                IF( iibe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    741743               IF( iibe==jpi+1                                                 )   lrecv_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE.   
    742                ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 
     744               ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo. 
    743745               ! :¨¨¨¨¨|¨¨-->    |                                             |    <--¨¨|¨¨¨¨¨:  
    744746               ! :     |  x:o    |    neighbour limited by ... would need o    |    o:x  |     : 
    745747               ! :.....|_._:_____|   (1) W neighbour         E neighbour (2)   |_____:_._|.....: 
    746                IF( ii==2     .AND. mpiSnei(nn_hls,jpwe) > -1 .AND. & 
    747                   & ( iibi==3     .OR. ii1==3     .OR. ii2==3     .OR. ii3==3    ) )   lsend_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    748                IF( ii==jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 .AND. & 
    749                   & ( iibi==jpi-2 .OR. ii1==jpi-2 .OR. ii2==jpi-2 .OR. ii3==jpi-2) )   lsend_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE. 
    750                IF( ii==2     .AND. mpiSnei(nn_hls,jpwe) > -1 .AND. iibe==3     )   lsend_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    751                IF( ii==jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 .AND. iibe==jpi-2 )   lsend_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE. 
     748               ! ==> the neighbour cannot compute the point x -> need to send it 
     749               IF( ii ==     2*nn_hls   .AND. mpiSnei(nn_hls,jpwe) > -1 ) THEN   ! 2*nn_hls      -> ji=jpi of western neighbour 
     750                  IF( iibi==ii+1 .OR. ii1==ii+1 .OR. ii2==ii+1 .OR. ii3==ii+1 )   lsend_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     751                  IF( iibe==ii+1                                              )   lsend_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     752               ENDIF 
     753               IF( ii == jpi-2*nn_hls+1 .AND. mpiSnei(nn_hls,jpea) > -1 ) THEN   ! jpi-2*nn_hls+1-> ji=1   of eastern neighbour 
     754                  IF( iibi==ii-1 .OR. ii1==ii-1 .OR. ii2==ii-1 .OR. ii3==ii-1 )   lsend_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE. 
     755                  IF( iibe==ii-1                                              )   lsend_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE. 
     756               ENDIF 
    752757               ! 
    753758               ! search neighbour in the north/south direction    
     759               ! 
    754760               ! Rim is on the halo and computed ocean is towards exterior of mpi domain 
     761               ! ==> cannot compute the point x -> need to receive it 
    755762               !(3)   |       |         ^   ___o___      
    756763               !  |   |___x___|   OR    |  |   x   | 
    757764               !  v       o           (4)  |       | 
    758765               IF( ijbi==0     .OR. ij1==0     .OR. ij2==0     .OR. ij3==0     )   lrecv_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 
     766               IF( ijbe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
    759767               IF( ijbi==jpj+1 .OR. ij1==jpj+1 .OR. ij2==jpj+1 .OR. ij3==jpj+1 )   lrecv_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 
    760                IF( ijbe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
    761768               IF( ijbe==jpj+1                                                 )   lrecv_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 
    762769               ! Check if neighbour has its rim parallel to its mpi subdomain     _________  border and next to its halo 
     
    764771               !   |  |¨¨¨¨x¨¨¨¨|   neighbour limited by ... would need o     |  |....x....| 
    765772               !      :_________:  (3) S neighbour          N neighbour (4)   v  |    o    |    
    766                IF( ij==2     .AND. mpiSnei(nn_hls,jpso) > -1 .AND. & 
    767                   & ( ijbi==3     .OR. ij1==3     .OR. ij2==3     .OR. ij3==3    ) )   lsend_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 
    768                IF( ij==jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 .AND. & 
    769                   & ( ijbi==jpj-2 .OR. ij1==jpj-2 .OR. ij2==jpj-2 .OR. ij3==jpj-2) )   lsend_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 
    770                IF( ij==2     .AND. mpiSnei(nn_hls,jpso) > -1 .AND. ijbe==3     )   lsend_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
    771                IF( ij==jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 .AND. ijbe==jpj-2 )   lsend_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 
     773               ! ==> the neighbour cannot compute the point x -> need to send it 
     774               IF( ij ==     2*nn_hls   .AND. mpiSnei(nn_hls,jpso) > -1 ) THEN   ! 2*nn_hls      -> jj=jpj of southern neighbour  
     775                  IF( ijbi==ij+1 .OR. ij1==ij+1 .OR. ij2==ij+1 .OR. ij3==ij+1 )   lsend_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 
     776                  IF( ijbe==ij+1                                              )   lsend_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
     777               ENDIF 
     778               IF( ij == jpj-2*nn_hls+1 .AND. mpiSnei(nn_hls,jpno) > -1 ) THEN   ! jpj-2*nn_hls+1-> jj=1   of northern neighbour 
     779                  IF( ijbi==ij-1 .OR. ij1==ij-1 .OR. ij2==ij-1 .OR. ij3==ij-1 )   lsend_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 
     780                  IF( ijbe==ij-1                                              )   lsend_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 
     781               ENDIF 
    772782            END DO 
    773783         END DO 
     
    813823      !!                - and look at the ocean neighbours to compute ntreat 
    814824      !!---------------------------------------------------------------------- 
    815       REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pfmask   ! temporary fmask excluding coastal boundary condition (shlat) 
    816       REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pumask, pvmask   ! temporary t/u/v mask array 
    817       LOGICAL                             , INTENT (in   ) :: lrim0    ! .true. -> rim 0   .false. -> rim 1 
     825      REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pumask, pvmask   ! temporary u/v mask array 
     826      REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pfmask           ! temporary fmask excluding coastal boundary condition (shlat) 
     827      LOGICAL                             , INTENT (in   ) :: lrim0            ! .true. -> rim 0   .false. -> rim 1 
    818828      INTEGER  ::   ib_bdy, ii, ij, igrd, ib, icount       ! dummy loop indices 
    819829      INTEGER  ::   i_offset, j_offset, inn                ! local integer 
     
    830840      DO ib_bdy = 1, nb_bdy       ! Indices and directions of rim velocity components 
    831841 
    832          ! Calculate relationship of U direction to the local orientation of the boundary 
    833          ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward 
    834          ! flagu =  0 : u is tangential 
    835          ! flagu =  1 : u is normal to the boundary and is direction is inward 
    836          DO igrd = 1, jpbgrd  
    837             SELECT CASE( igrd ) 
    838                CASE( 1 )   ;   zmask => pumask     ;   i_offset = 0 
    839                CASE( 2 )   ;   zmask => bdytmask   ;   i_offset = 1 
    840                CASE( 3 )   ;   zmask => pfmask     ;   i_offset = 0 
    841             END SELECT  
    842             icount = 0 
    843             ztmp(:,:) = -999._wp 
     842         DO igrd = 1, jpbgrd 
     843             
    844844            IF( lrim0 ) THEN   ! extent of rim 0 
    845845               ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
     
    847847               ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
    848848            END IF 
     849 
     850            ! Calculate relationship of U direction to the local orientation of the boundary 
     851            ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward 
     852            ! flagu =  0 : u is tangential 
     853            ! flagu =  1 : u is normal to the boundary and is direction is inward 
     854            SELECT CASE( igrd ) 
     855               CASE( 1 )   ;   zmask => pumask     ;   i_offset = 0   ! U(i-1)   T(i)   U(i  ) 
     856               CASE( 2 )   ;   zmask => bdytmask   ;   i_offset = 1   ! T(i  )   U(i)   T(i+1) 
     857               CASE( 3 )   ;   zmask => pfmask     ;   i_offset = 0   ! F(i-1)   V(i)   F(i  ) 
     858            END SELECT  
     859            icount = 0 
     860            ztmp(:,:) = -999._wp 
    849861            DO ib = ibeg, iend  
    850862               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    851863               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    852                IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
     864               IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 )  CYCLE   ! call lbc_lnk -> no need to compute these pts 
    853865               zwfl = zmask(ii+i_offset-1,ij) 
    854866               zefl = zmask(ii+i_offset  ,ij) 
    855                ! This error check only works if you are using the bdyXmask arrays 
    856                IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN 
     867               ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) 
     868               IF( i_offset == 1 .and. zefl + zwfl == 2._wp ) THEN 
    857869                  icount = icount + 1 
    858870                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 
     
    876888               idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) 
    877889            END DO 
    878          END DO 
    879  
    880          ! Calculate relationship of V direction to the local orientation of the boundary 
    881          ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward 
    882          ! flagv =  0 : v is tangential 
    883          ! flagv =  1 : v is normal to the boundary and is direction is inward 
    884          DO igrd = 1, jpbgrd  
     890             
     891            ! Calculate relationship of V direction to the local orientation of the boundary 
     892            ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward 
     893            ! flagv =  0 : v is tangential 
     894            ! flagv =  1 : v is normal to the boundary and is direction is inward 
    885895            SELECT CASE( igrd ) 
    886896               CASE( 1 )   ;   zmask => pvmask     ;   j_offset = 0 
     
    890900            icount = 0 
    891901            ztmp(:,:) = -999._wp 
    892             IF( lrim0 ) THEN   ! extent of rim 0 
    893                ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
    894             ELSE               ! extent of rim 1 
    895                ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
    896             END IF 
    897902            DO ib = ibeg, iend 
    898903               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    899904               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    900                IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
     905               IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 )  CYCLE   ! call lbc_lnk -> no need to compute these pts 
    901906               zsfl = zmask(ii,ij+j_offset-1) 
    902907               znfl = zmask(ii,ij+j_offset  ) 
    903                ! This error check only works if you are using the bdyXmask arrays 
    904                IF( j_offset == 1 .and. znfl + zsfl == 2. ) THEN 
     908               ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) 
     909               IF( j_offset == 1 .and. znfl + zsfl == 2._wp ) THEN 
    905910                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 
    906911                  icount = icount + 1 
     
    924929               idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) 
    925930            END DO 
    926          END DO 
    927          ! 
    928       END DO ! ib_bdy 
    929931       
    930       DO ib_bdy = 1, nb_bdy 
    931          DO igrd = 1, jpbgrd 
     932            ! Calculate ntreat 
    932933            SELECT CASE( igrd ) 
    933934               CASE( 1 )   ;   zmask => bdytmask  
     
    936937            END SELECT 
    937938            ztmp(:,:) = -999._wp 
    938             IF( lrim0 ) THEN   ! extent of rim 0 
    939                ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
    940             ELSE               ! extent of rim 1 
    941                ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
    942             END IF 
    943939            DO ib = ibeg, iend 
    944940               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    945941               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    946                IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )   CYCLE 
    947                llnon = zmask(ii  ,ij+1) == 1.   
    948                llson = zmask(ii  ,ij-1) == 1.  
    949                llean = zmask(ii+1,ij  ) == 1.  
    950                llwen = zmask(ii-1,ij  ) == 1.  
     942               IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 )  CYCLE   ! call lbc_lnk -> no need to compute these pts 
     943               llnon = zmask(ii  ,ij+1) == 1._wp   
     944               llson = zmask(ii  ,ij-1) == 1._wp  
     945               llean = zmask(ii+1,ij  ) == 1._wp  
     946               llwen = zmask(ii-1,ij  ) == 1._wp  
    951947               inn  = COUNT( (/ llnon, llson, llean, llwen /) ) 
    952948               IF( inn == 0 ) THEN   ! no neighbours -> interior of a corner  or  cluster of rim points 
     
    954950                  !  1 |   o      !  2  o   |    !  3 | x        !  4     x |   !      |   |   -> error 
    955951                  !    |_x_ _     !    _ _x_|    !    |   o      !      o   |   !      |x_x| 
    956                   IF(     zmask(ii+1,ij+1) == 1. ) THEN   ;   ztmp(ii,ij) = 1. 
    957                   ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN   ;   ztmp(ii,ij) = 2. 
    958                   ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN   ;   ztmp(ii,ij) = 3. 
    959                   ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN   ;   ztmp(ii,ij) = 4. 
    960                   ELSE                                    ;   ztmp(ii,ij) = -1. 
     952                  IF(     zmask(ii+1,ij+1) == 1._wp ) THEN   ;   ztmp(ii,ij) = 1._wp 
     953                  ELSEIF( zmask(ii-1,ij+1) == 1._wp ) THEN   ;   ztmp(ii,ij) = 2._wp 
     954                  ELSEIF( zmask(ii+1,ij-1) == 1._wp ) THEN   ;   ztmp(ii,ij) = 3._wp 
     955                  ELSEIF( zmask(ii-1,ij-1) == 1._wp ) THEN   ;   ztmp(ii,ij) = 4._wp 
     956                  ELSE                                       ;   ztmp(ii,ij) = -1._wp 
    961957                     WRITE(ctmp1,*) 'Problem with  ',cgrid(igrd) ,' grid point', ii, ij,   & 
    962958                       ' on boundary set ', ib_bdy, ' has no free ocean neighbour' 
     
    973969                  ! 5  | x o     ! 6   o x |   ! 7  __x__   ! 8    x 
    974970                  !    |         !         |   !            !      o 
    975                   IF( llean )   ztmp(ii,ij) = 5. 
    976                   IF( llwen )   ztmp(ii,ij) = 6. 
    977                   IF( llnon )   ztmp(ii,ij) = 7. 
    978                   IF( llson )   ztmp(ii,ij) = 8. 
     971                  IF( llean )   ztmp(ii,ij) = 5._wp 
     972                  IF( llwen )   ztmp(ii,ij) = 6._wp 
     973                  IF( llnon )   ztmp(ii,ij) = 7._wp 
     974                  IF( llson )   ztmp(ii,ij) = 8._wp 
    979975               END IF 
    980976               IF( inn == 2 ) THEN   ! exterior of a corner 
     
    982978                  !  9 ____x o    ! 10   o x___   ! 11     x o      ! 12   o x       
    983979                  !         |     !       |       !        o        !        o  
    984                   IF( llnon .AND. llean )   ztmp(ii,ij) =  9. 
    985                   IF( llnon .AND. llwen )   ztmp(ii,ij) = 10. 
    986                   IF( llson .AND. llean )   ztmp(ii,ij) = 11. 
    987                   IF( llson .AND. llwen )   ztmp(ii,ij) = 12. 
     980                  IF( llnon .AND. llean )   ztmp(ii,ij) =  9._wp 
     981                  IF( llnon .AND. llwen )   ztmp(ii,ij) = 10._wp 
     982                  IF( llson .AND. llean )   ztmp(ii,ij) = 11._wp 
     983                  IF( llson .AND. llwen )   ztmp(ii,ij) = 12._wp 
    988984               END IF 
    989985               IF( inn == 3 ) THEN   ! 3 neighbours     __   __ 
     
    991987                  ! 13  _| x o    ! 14   o x |_   ! 15   o x o    ! 16  o x o        
    992988                  !    |   o      !        o   |  !        o      !    __|¨|__     
    993                   IF( llnon .AND. llean .AND. llson )   ztmp(ii,ij) = 13. 
    994                   IF( llnon .AND. llwen .AND. llson )   ztmp(ii,ij) = 14. 
    995                   IF( llwen .AND. llson .AND. llean )   ztmp(ii,ij) = 15. 
    996                   IF( llwen .AND. llnon .AND. llean )   ztmp(ii,ij) = 16. 
     989                  IF( llnon .AND. llean .AND. llson )   ztmp(ii,ij) = 13._wp 
     990                  IF( llnon .AND. llwen .AND. llson )   ztmp(ii,ij) = 14._wp 
     991                  IF( llwen .AND. llson .AND. llean )   ztmp(ii,ij) = 15._wp 
     992                  IF( llwen .AND. llnon .AND. llean )   ztmp(ii,ij) = 16._wp 
    997993               END IF 
    998994               IF( inn == 4 ) THEN 
     
    10121008               idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) 
    10131009            END DO 
    1014          END DO 
    1015       END DO 
     1010            ! 
     1011         END DO   ! jpbgrd 
     1012         ! 
     1013      END DO   ! ib_bdy 
    10161014 
    10171015    END SUBROUTINE bdy_rim_treat 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DIA/dia25h.F90

    r12489 r15349  
    3232   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   en_25h  , rmxln_25h 
    3333 
     34!! * Substitutions 
     35#  include "do_loop_substitute.h90" 
    3436   !!---------------------------------------------------------------------- 
    3537   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
     
    5153      INTEGER ::   ios                 ! Local integer output status for namelist read 
    5254      INTEGER ::   ierror              ! Local integer for memory allocation 
     55      INTEGER ::   ji, jj, jk 
    5356      ! 
    5457      NAMELIST/nam_dia25h/ ln_dia25h 
     
    7376      ! ------------------- ! 
    7477      !                                ! ocean arrays 
    75       ALLOCATE( tn_25h (jpi,jpj,jpk), sn_25h (jpi,jpj,jpk), sshn_25h(jpi,jpj)  ,     & 
    76          &      un_25h (jpi,jpj,jpk), vn_25h (jpi,jpj,jpk), wn_25h(jpi,jpj,jpk),     & 
    77          &      avt_25h(jpi,jpj,jpk), avm_25h(jpi,jpj,jpk),                      STAT=ierror ) 
     78      ALLOCATE( tn_25h (A2D(0),jpk), sn_25h (A2D(0),jpk), sshn_25h(A2D(0))  ,     & 
     79         &      un_25h (A2D(0),jpk), vn_25h (A2D(0),jpk), wn_25h(A2D(0),jpk),     & 
     80         &      avt_25h(A2D(0),jpk), avm_25h(A2D(0),jpk),                      STAT=ierror ) 
    7881      IF( ierror > 0 ) THEN 
    7982         CALL ctl_stop( 'dia_25h: unable to allocate ocean arrays' )   ;   RETURN 
    8083      ENDIF 
    8184      IF( ln_zdftke ) THEN             ! TKE physics 
    82          ALLOCATE( en_25h(jpi,jpj,jpk), STAT=ierror ) 
     85         ALLOCATE( en_25h(A2D(0),jpk), STAT=ierror ) 
    8386         IF( ierror > 0 ) THEN 
    8487            CALL ctl_stop( 'dia_25h: unable to allocate en_25h' )   ;   RETURN 
     
    8689      ENDIF 
    8790      IF( ln_zdfgls ) THEN             ! GLS physics 
    88          ALLOCATE( en_25h(jpi,jpj,jpk), rmxln_25h(jpi,jpj,jpk), STAT=ierror ) 
     91         ALLOCATE( en_25h(A2D(0),jpk), rmxln_25h(A2D(0),jpk), STAT=ierror ) 
    8992         IF( ierror > 0 ) THEN 
    9093            CALL ctl_stop( 'dia_25h: unable to allocate en_25h and rmxln_25h' )   ;   RETURN 
     
    9497      ! 2 - Assign Initial Values ! 
    9598      ! ------------------------- ! 
    96       cnt_25h = 1  ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible)  
    97       tn_25h  (:,:,:) = ts (:,:,:,jp_tem,Kbb) 
    98       sn_25h  (:,:,:) = ts (:,:,:,jp_sal,Kbb) 
    99       sshn_25h(:,:)   = ssh(:,:,Kbb) 
    100       un_25h  (:,:,:) = uu  (:,:,:,Kbb) 
    101       vn_25h  (:,:,:) = vv  (:,:,:,Kbb) 
    102       avt_25h (:,:,:) = avt (:,:,:) 
    103       avm_25h (:,:,:) = avm (:,:,:) 
     99      cnt_25h = 1  ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible) 
     100      DO_3D( 0, 0, 0, 0, 1, jpk ) 
     101         tn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kbb) 
     102         sn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kbb) 
     103         un_25h (ji,jj,jk) = uu (ji,jj,jk,Kbb) 
     104         vn_25h (ji,jj,jk) = vv (ji,jj,jk,Kbb) 
     105         avt_25h(ji,jj,jk) = avt(ji,jj,jk) 
     106         avm_25h(ji,jj,jk) = avm(ji,jj,jk) 
     107      END_3D 
     108      DO_2D( 0, 0, 0, 0 ) 
     109         sshn_25h(ji,jj) = ssh(ji,jj,Kbb) 
     110      END_2D 
    104111      IF( ln_zdftke ) THEN 
    105          en_25h(:,:,:) = en(:,:,:) 
     112         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     113            en_25h(ji,jj,jk) = en(ji,jj,jk) 
     114         END_3D 
    106115      ENDIF 
    107116      IF( ln_zdfgls ) THEN 
    108          en_25h   (:,:,:) = en    (:,:,:) 
    109          rmxln_25h(:,:,:) = hmxl_n(:,:,:) 
     117         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     118            en_25h   (ji,jj,jk) = en    (ji,jj,jk) 
     119            rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) 
     120         END_3D 
    110121      ENDIF 
    111122#if defined key_si3 
     
    132143      REAL(wp)                         ::   zsto, zout, zmax, zjulian, zmdi   ! local scalars 
    133144      INTEGER                          ::   i_steps                           ! no of timesteps per hour 
    134       REAL(wp), DIMENSION(jpi,jpj    ) ::   zw2d, un_dm, vn_dm                ! workspace 
    135       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d                              ! workspace 
    136       REAL(wp), DIMENSION(jpi,jpj,3)   ::   zwtmb                             ! workspace 
     145      REAL(wp), DIMENSION(A2D(0)    ) ::   zw2d, un_dm, vn_dm                ! workspace 
     146      REAL(wp), DIMENSION(A2D(0),jpk) ::   zw3d                              ! workspace 
     147      REAL(wp), DIMENSION(A2D(0),3)    ::   zwtmb                             ! workspace 
    137148      !!---------------------------------------------------------------------- 
    138149 
     
    151162      ! wn_25h could not be initialised in dia_25h_init, so we do it here instead 
    152163      IF( kt == nn_it000 ) THEN 
    153          wn_25h(:,:,:) = ww(:,:,:) 
     164         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     165            wn_25h(ji,jj,jk) = ww(ji,jj,jk) 
     166         END_3D 
    154167      ENDIF 
    155168 
     
    162175         ENDIF 
    163176 
    164          tn_25h  (:,:,:)     = tn_25h  (:,:,:) + ts (:,:,:,jp_tem,Kmm) 
    165          sn_25h  (:,:,:)     = sn_25h  (:,:,:) + ts (:,:,:,jp_sal,Kmm) 
    166          sshn_25h(:,:)       = sshn_25h(:,:)   + ssh(:,:,Kmm) 
    167          un_25h  (:,:,:)     = un_25h  (:,:,:) + uu  (:,:,:,Kmm) 
    168          vn_25h  (:,:,:)     = vn_25h  (:,:,:) + vv  (:,:,:,Kmm) 
    169          wn_25h  (:,:,:)     = wn_25h  (:,:,:) + ww  (:,:,:) 
    170          avt_25h (:,:,:)     = avt_25h (:,:,:) + avt (:,:,:) 
    171          avm_25h (:,:,:)     = avm_25h (:,:,:) + avm (:,:,:) 
     177         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     178            tn_25h  (ji,jj,jk) = tn_25h  (ji,jj,jk) + ts (ji,jj,jk,jp_tem,Kmm) 
     179            sn_25h  (ji,jj,jk) = sn_25h  (ji,jj,jk) + ts (ji,jj,jk,jp_sal,Kmm) 
     180            un_25h  (ji,jj,jk) = un_25h  (ji,jj,jk) + uu (ji,jj,jk,Kmm) 
     181            vn_25h  (ji,jj,jk) = vn_25h  (ji,jj,jk) + vv (ji,jj,jk,Kmm) 
     182            wn_25h  (ji,jj,jk) = wn_25h  (ji,jj,jk) + ww (ji,jj,jk) 
     183            avt_25h (ji,jj,jk) = avt_25h (ji,jj,jk) + avt(ji,jj,jk) 
     184            avm_25h (ji,jj,jk) = avm_25h (ji,jj,jk) + avm(ji,jj,jk) 
     185         END_3D 
     186         DO_2D( 0, 0, 0, 0 ) 
     187            sshn_25h(ji,jj)    = sshn_25h(ji,jj)    + ssh(ji,jj,Kmm) 
     188         END_2D 
    172189         IF( ln_zdftke ) THEN 
    173             en_25h(:,:,:)    = en_25h  (:,:,:) + en(:,:,:) 
     190            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     191               en_25h(ji,jj,jk) = en_25h(ji,jj,jk) + en(ji,jj,jk) 
     192            END_3D 
    174193         ENDIF 
    175194         IF( ln_zdfgls ) THEN 
    176             en_25h   (:,:,:) = en_25h   (:,:,:) + en    (:,:,:) 
    177             rmxln_25h(:,:,:) = rmxln_25h(:,:,:) + hmxl_n(:,:,:) 
     195            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     196               en_25h   (ji,jj,jk) = en_25h   (ji,jj,jk) + en    (ji,jj,jk) 
     197               rmxln_25h(ji,jj,jk) = rmxln_25h(ji,jj,jk) + hmxl_n(ji,jj,jk) 
     198            END_3D 
    178199         ENDIF 
    179200         cnt_25h = cnt_25h + 1 
     
    212233         zmdi=1.e+20 !missing data indicator for masking 
    213234         ! write tracers (instantaneous) 
    214          zw3d(:,:,:) = tn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     235         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     236            zw3d(ji,jj,jk) = tn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     237         END_3D 
    215238         CALL iom_put("temper25h", zw3d)   ! potential temperature 
    216          zw3d(:,:,:) = sn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     239         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     240            zw3d(ji,jj,jk) = sn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     241         END_3D 
    217242         CALL iom_put( "salin25h", zw3d  )   ! salinity 
    218          zw2d(:,:) = sshn_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     243         DO_2D( 0, 0, 0, 0 ) 
     244            zw2d(ji,jj) = sshn_25h(ji,jj)*tmask(ji,jj,1) + zmdi*(1.0-tmask(ji,jj,1)) 
     245         END_2D 
    219246         IF( ll_wd ) THEN 
    220247            CALL iom_put( "ssh25h", zw2d+ssh_ref )   ! sea surface  
     
    223250         ENDIF 
    224251         ! Write velocities (instantaneous) 
    225          zw3d(:,:,:) = un_25h(:,:,:)*umask(:,:,:) + zmdi*(1.0-umask(:,:,:)) 
     252         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     253            zw3d(ji,jj,jk) = un_25h(ji,jj,jk)*umask(ji,jj,jk) + zmdi*(1.0-umask(ji,jj,jk)) 
     254         END_3D 
    226255         CALL iom_put("vozocrtx25h", zw3d)    ! i-current 
    227          zw3d(:,:,:) = vn_25h(:,:,:)*vmask(:,:,:) + zmdi*(1.0-vmask(:,:,:)) 
     256         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     257            zw3d(ji,jj,jk) = vn_25h(ji,jj,jk)*vmask(ji,jj,jk) + zmdi*(1.0-vmask(ji,jj,jk)) 
     258         END_3D 
    228259         CALL iom_put("vomecrty25h", zw3d  )   ! j-current 
    229          zw3d(:,:,:) = wn_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     260         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     261            zw3d(ji,jj,jk) = wn_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     262         END_3D 
    230263         CALL iom_put("vovecrtz25h", zw3d )   ! k-current 
    231264         ! Write vertical physics 
    232          zw3d(:,:,:) = avt_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     265         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     266            zw3d(ji,jj,jk) = avt_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     267         END_3D 
    233268         CALL iom_put("avt25h", zw3d )   ! diffusivity 
    234          zw3d(:,:,:) = avm_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     269         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     270            zw3d(ji,jj,jk) = avm_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     271         END_3D 
    235272         CALL iom_put("avm25h", zw3d)   ! viscosity 
    236273         IF( ln_zdftke ) THEN 
    237             zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     274            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     275               zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     276            END_3D 
    238277            CALL iom_put("tke25h", zw3d)   ! tke 
    239278         ENDIF 
    240279         IF( ln_zdfgls ) THEN 
    241             zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     280            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     281               zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     282            END_3D 
    242283            CALL iom_put("tke25h", zw3d)   ! tke 
    243             zw3d(:,:,:) = rmxln_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     284            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     285               zw3d(ji,jj,jk) = rmxln_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) 
     286            END_3D 
    244287            CALL iom_put( "mxln25h",zw3d) 
    245288         ENDIF 
    246289         ! 
    247290         ! After the write reset the values to cnt=1 and sum values equal current value  
    248          tn_25h  (:,:,:) = ts (:,:,:,jp_tem,Kmm) 
    249          sn_25h  (:,:,:) = ts (:,:,:,jp_sal,Kmm) 
    250          sshn_25h(:,:)   = ssh(:,:,Kmm) 
    251          un_25h  (:,:,:) = uu  (:,:,:,Kmm) 
    252          vn_25h  (:,:,:) = vv  (:,:,:,Kmm) 
    253          wn_25h  (:,:,:) = ww  (:,:,:) 
    254          avt_25h (:,:,:) = avt (:,:,:) 
    255          avm_25h (:,:,:) = avm (:,:,:) 
     291         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     292            tn_25h  (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kmm) 
     293            sn_25h  (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kmm) 
     294            un_25h  (ji,jj,jk) = uu (ji,jj,jk,Kmm) 
     295            vn_25h  (ji,jj,jk) = vv (ji,jj,jk,Kmm) 
     296            wn_25h  (ji,jj,jk) = ww (ji,jj,jk) 
     297            avt_25h (ji,jj,jk) = avt(ji,jj,jk) 
     298            avm_25h (ji,jj,jk) = avm(ji,jj,jk) 
     299         END_3D 
     300         DO_2D( 0, 0, 0, 0 ) 
     301            sshn_25h(ji,jj)    = ssh(ji,jj,Kmm) 
     302         END_2D 
    256303         IF( ln_zdftke ) THEN 
    257             en_25h(:,:,:) = en(:,:,:) 
     304            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     305               en_25h(ji,jj,jk) = en(ji,jj,jk) 
     306            END_3D 
    258307         ENDIF 
    259308         IF( ln_zdfgls ) THEN 
    260             en_25h   (:,:,:) = en    (:,:,:) 
    261             rmxln_25h(:,:,:) = hmxl_n(:,:,:) 
     309            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     310               en_25h   (ji,jj,jk) = en    (ji,jj,jk) 
     311               rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) 
     312            END_3D 
    262313         ENDIF 
    263314         cnt_25h = 1 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DIA/diahth.F90

    r13497 r15349  
    334334   SUBROUTINE dia_hth_htc( Kmm, pdep, pt, phtc ) 
    335335      ! 
    336       INTEGER , INTENT(in) :: Kmm      ! ocean time level index 
    337       REAL(wp), INTENT(in) :: pdep     ! depth over the heat content 
    338       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pt    
    339       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc   
    340       ! 
    341       INTEGER  :: ji, jj, jk, ik 
    342       REAL(wp), DIMENSION(jpi,jpj) :: zthick 
    343       INTEGER , DIMENSION(jpi,jpj) :: ilevel 
     336      INTEGER , INTENT(in) ::   Kmm      ! ocean time level index 
     337      REAL(wp), INTENT(in) ::   pdep     ! depth over the heat content 
     338      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)    ::  pt    
     339      REAL(wp), DIMENSION(jpi,jpj),     INTENT(inout) ::  phtc   
     340      ! 
     341      INTEGER  ::   ji, jj, jk, ik 
     342      REAL(wp), DIMENSION(jpi,jpj) ::   zthick 
     343      INTEGER , DIMENSION(jpi,jpj) ::   ilevel 
    344344 
    345345 
    346346      ! surface boundary condition 
    347347       
    348       IF( .NOT. ln_linssh ) THEN   ;   zthick(:,:) = 0._wp       ;   phtc(:,:) = 0._wp                                    
     348      IF( .NOT. ln_linssh ) THEN   ;   zthick(:,:) = 0._wp          ;   phtc(:,:) = 0._wp                                    
    349349      ELSE                         ;   zthick(:,:) = ssh(:,:,Kmm)   ;   phtc(:,:) = pt(:,:,1) * ssh(:,:,Kmm) * tmask(:,:,1)    
    350350      ENDIF 
    351351      ! 
    352352      ilevel(:,:) = 1 
    353       DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
    354          IF( ( gdept(ji,jj,jk,Kmm) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN 
    355              ilevel(ji,jj) = jk 
     353      DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     354         IF( ( gdepw(ji,jj,jk+1,Kmm) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN 
     355             ilevel(ji,jj) = jk+1 
    356356             zthick(ji,jj) = zthick(ji,jj) + e3t(ji,jj,jk,Kmm) 
    357357             phtc  (ji,jj) = phtc  (ji,jj) + e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk) 
     
    361361      DO_2D( 1, 1, 1, 1 ) 
    362362         ik = ilevel(ji,jj) 
    363          zthick(ji,jj) = pdep - zthick(ji,jj)   !   remaining thickness to reach depht pdep 
    364          phtc(ji,jj)   = phtc(ji,jj)    & 
    365             &           + pt (ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) & 
    366                                                        * tmask(ji,jj,ik+1) 
     363         IF( tmask(ji,jj,ik) == 1 ) THEN 
     364            zthick(ji,jj) = MIN ( gdepw(ji,jj,ik+1,Kmm), pdep ) - zthick(ji,jj)   ! remaining thickness to reach dephw pdep 
     365            phtc(ji,jj)   = phtc(ji,jj) + pt(ji,jj,ik) * zthick(ji,jj) 
     366         ENDIF 
    367367      END_2D 
    368       ! 
    369368      ! 
    370369   END SUBROUTINE dia_hth_htc 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DIA/diawri.F90

    r15127 r15349  
    583583      REAL(wp) ::   zsto, zout, zmax, zjulian                ! local scalars 
    584584      ! 
    585       REAL(wp), DIMENSION(jpi,jpj)   :: zw2d       ! 2D workspace 
    586       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept       ! 3D workspace 
     585      REAL(wp), DIMENSION(jpi,jpj    ) :: z2d     ! 2D workspace 
     586      REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d     ! 3D workspace 
    587587      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl   ! ABL 3D workspace 
    588588      !!---------------------------------------------------------------------- 
     
    624624      it = kt 
    625625      itmod = kt - nit000 + 1 
    626  
    627       ! store e3t for subsitute 
    628       DO jk = 1, jpk 
    629          ze3t  (:,:,jk) =  e3t  (:,:,jk,Kmm) 
    630          zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
    631       END DO 
    632  
    633626 
    634627      ! 1. Define NETCDF files and fields at beginning of first time step 
     
    786779         CALL histdef( nid_T, "soshfldo", "Shortwave Radiation"                , "W/m2"   ,   &  ! qsr 
    787780            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    788          CALL histdef( nid_T, "somixhgt", "Turbocline Depth"                   , "m"      ,   &  ! hmld 
    789             &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    790          CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01"             , "m"      ,   &  ! hmlp 
    791             &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     781         IF( ALLOCATED(hmld) ) THEN   ! zdf_mxl not called by SWE 
     782            CALL histdef( nid_T, "somixhgt", "Turbocline Depth"                   , "m"      ,   &  ! hmld 
     783               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     784            CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01"             , "m"      ,   &  ! hmlp 
     785               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     786         ENDIF 
    792787         CALL histdef( nid_T, "soicecov", "Ice fraction"                       , "[0,1]"  ,   &  ! fr_i 
    793788            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     
    942937 
    943938      IF( .NOT.ln_linssh ) THEN 
    944          CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! heat content 
    945          CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! salt content 
    946          CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface heat content 
    947          CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface salinity content 
     939         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     940            z3d(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) 
     941         END_3D 
     942         CALL histwrite( nid_T, "votemper", it, z3d, ndim_T , ndex_T  )   ! heat content 
     943         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     944            z3d(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) 
     945         END_3D 
     946         CALL histwrite( nid_T, "vosaline", it, z3d, ndim_T , ndex_T  )   ! salt content 
     947         DO_2D( 0, 0, 0, 0 ) 
     948            z2d(ji,jj   ) = ts(ji,jj, 1,jp_tem,Kmm) * e3t(ji,jj, 1,Kmm) 
     949         END_2D 
     950         CALL histwrite( nid_T, "sosstsst", it, z2d, ndim_hT, ndex_hT )   ! sea surface heat content 
     951         DO_2D( 0, 0, 0, 0 ) 
     952            z2d(ji,jj   ) = ts(ji,jj, 1,jp_sal,Kmm) * e3t(ji,jj, 1,Kmm) 
     953         END_2D 
     954         CALL histwrite( nid_T, "sosaline", it, z2d, ndim_hT, ndex_hT )   ! sea surface salinity content 
    948955      ELSE 
    949956         CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T  )   ! temperature 
     
    953960      ENDIF 
    954961      IF( .NOT.ln_linssh ) THEN 
    955          zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
    956          CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:)     , ndim_T , ndex_T  )   ! level thickness 
    957          CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T  )   ! t-point depth  
    958          CALL histwrite( nid_T, "vovvldef", it, zw3d             , ndim_T , ndex_T  )   ! level thickness deformation 
    959       ENDIF 
    960       CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm)          , ndim_hT, ndex_hT )   ! sea surface height 
    961       CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf )   , ndim_hT, ndex_hT )   ! upward water flux 
     962         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     963           z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm)     ! 3D workspace for qco substitution 
     964         END_3D 
     965         CALL histwrite( nid_T, "vovvle3t", it, z3d        , ndim_T , ndex_T  )   ! level thickness 
     966         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     967           z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm)   ! 3D workspace for qco substitution 
     968         END_3D 
     969         CALL histwrite( nid_T, "vovvldep", it, z3d        , ndim_T , ndex_T  )   ! t-point depth  
     970         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     971            z3d(ji,jj,jk) = ( ( e3t(ji,jj,jk,Kmm) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2 
     972         END_3D          
     973         CALL histwrite( nid_T, "vovvldef", it, z3d        , ndim_T , ndex_T  )   ! level thickness deformation 
     974      ENDIF 
     975      CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm)  , ndim_hT, ndex_hT )   ! sea surface height 
     976      DO_2D( 0, 0, 0, 0 ) 
     977         z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) 
     978      END_2D 
     979      CALL histwrite( nid_T, "sowaflup", it, z2d           , ndim_hT, ndex_hT )   ! upward water flux 
    962980      CALL histwrite( nid_T, "sorunoff", it, rnf           , ndim_hT, ndex_hT )   ! river runoffs 
    963981      CALL histwrite( nid_T, "sosfldow", it, sfx           , ndim_hT, ndex_hT )   ! downward salt flux  
     
    965983                                                                                  ! in linear free surface case) 
    966984      IF( ln_linssh ) THEN 
    967          zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_tem,Kmm) 
    968          CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sst 
    969          zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_sal,Kmm) 
    970          CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sss 
    971       ENDIF 
    972       CALL histwrite( nid_T, "sohefldo", it, qns + qsr     , ndim_hT, ndex_hT )   ! total heat flux 
     985         DO_2D( 0, 0, 0, 0 ) 
     986            z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_tem,Kmm) 
     987         END_2D 
     988         CALL histwrite( nid_T, "sosst_cd", it, z2d, ndim_hT, ndex_hT )          ! c/d term on sst 
     989         DO_2D( 0, 0, 0, 0 ) 
     990            z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_sal,Kmm) 
     991         END_2D 
     992         CALL histwrite( nid_T, "sosss_cd", it, z2d, ndim_hT, ndex_hT )          ! c/d term on sss 
     993      ENDIF 
     994      DO_2D( 0, 0, 0, 0 ) 
     995         z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) 
     996      END_2D 
     997      CALL histwrite( nid_T, "sohefldo", it, z2d           , ndim_hT, ndex_hT )   ! total heat flux 
    973998      CALL histwrite( nid_T, "soshfldo", it, qsr           , ndim_hT, ndex_hT )   ! solar heat flux 
    974       CALL histwrite( nid_T, "somixhgt", it, hmld          , ndim_hT, ndex_hT )   ! turbocline depth 
    975       CALL histwrite( nid_T, "somxl010", it, hmlp          , ndim_hT, ndex_hT )   ! mixed layer depth 
     999      IF( ALLOCATED(hmld) ) THEN   ! zdf_mxl not called by SWE 
     1000         CALL histwrite( nid_T, "somixhgt", it, hmld          , ndim_hT, ndex_hT )   ! turbocline depth 
     1001         CALL histwrite( nid_T, "somxl010", it, hmlp          , ndim_hT, ndex_hT )   ! mixed layer depth 
     1002      ENDIF 
    9761003      CALL histwrite( nid_T, "soicecov", it, fr_i          , ndim_hT, ndex_hT )   ! ice fraction    
    9771004      CALL histwrite( nid_T, "sowindsp", it, wndm          , ndim_hT, ndex_hT )   ! wind speed    
     
    10261053         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    10271054         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    1028          zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1) 
    1029          CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
     1055         DO_2D( 0, 0, 0, 0 ) 
     1056            z2d(ji,jj) = erp(ji,jj) * ts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) 
     1057         END_2D 
     1058         CALL histwrite( nid_T, "sosafldp", it, z2d           , ndim_hT, ndex_hT )   ! salt flux damping 
    10301059      ENDIF 
    10311060!      zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) 
     
    10391068#endif 
    10401069 
    1041       CALL histwrite( nid_U, "vozocrtx", it, uu(:,:,:,Kmm)            , ndim_U , ndex_U )    ! i-current 
     1070      CALL histwrite( nid_U, "vozocrtx", it, uu(:,:,:,Kmm) , ndim_U , ndex_U )    ! i-current 
    10421071      CALL histwrite( nid_U, "sozotaux", it, utau          , ndim_hU, ndex_hU )   ! i-wind stress 
    10431072 
    1044       CALL histwrite( nid_V, "vomecrty", it, vv(:,:,:,Kmm)            , ndim_V , ndex_V  )   ! j-current 
     1073      CALL histwrite( nid_V, "vomecrty", it, vv(:,:,:,Kmm) , ndim_V , ndex_V  )   ! j-current 
    10451074      CALL histwrite( nid_V, "sometauy", it, vtau          , ndim_hV, ndex_hV )   ! j-wind stress 
    10461075 
    10471076      IF( ln_zad_Aimp ) THEN 
    1048          CALL histwrite( nid_W, "vovecrtz", it, ww + wi     , ndim_T, ndex_T )    ! vert. current 
     1077         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     1078           z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) 
     1079         END_3D          
     1080         CALL histwrite( nid_W, "vovecrtz", it, z3d         , ndim_T, ndex_T )    ! vert. current 
    10491081      ELSE 
    10501082         CALL histwrite( nid_W, "vovecrtz", it, ww          , ndim_T, ndex_T )    ! vert. current 
     
    10931125      CHARACTER (len=* ), INTENT( in ) ::   cdfile_name      ! name of the file created 
    10941126      !! 
    1095       INTEGER :: inum, jk 
    1096       REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept       ! 3D workspace for qco substitution 
     1127      INTEGER ::   ji, jj, jk       ! dummy loop indices 
     1128      INTEGER ::   inum 
     1129      REAL(wp), DIMENSION(jpi,jpj)     :: z2d       
     1130      REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d       
    10971131      !!---------------------------------------------------------------------- 
    10981132      !  
     
    11041138      ENDIF  
    11051139      ! 
    1106       DO jk = 1, jpk 
    1107          ze3t(:,:,jk) =  e3t(:,:,jk,Kmm) 
    1108          zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
    1109       END DO 
    1110       ! 
    11111140      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 
    11121141      ! 
    11131142      CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) )    ! now temperature 
    11141143      CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) )    ! now salinity 
    1115       CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm)              )    ! sea surface height 
    1116       CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm)                )    ! now i-velocity 
    1117       CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm)                )    ! now j-velocity 
     1144      CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm)         )    ! sea surface height 
     1145      CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm)        )    ! now i-velocity 
     1146      CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm)        )    ! now j-velocity 
    11181147      IF( ln_zad_Aimp ) THEN 
    1119          CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww + wi        )    ! now k-velocity 
     1148         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     1149           z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) 
     1150         END_3D 
     1151         CALL iom_rstput( 0, 0, inum, 'vovecrtz', z3d            )    ! now k-velocity 
    11201152      ELSE 
    11211153         CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww             )    ! now k-velocity 
    11221154      ENDIF 
    1123       CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep            )    ! now k-velocity 
     1155      CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep            ) 
    11241156      CALL iom_rstput( 0, 0, inum, 'ht'     , ht(:,:)            )    ! now water column height 
    11251157      ! 
    11261158      IF ( ln_isf ) THEN 
    11271159         IF (ln_isfcav_mlt) THEN 
    1128             CALL iom_rstput( 0, 0, inum, 'fwfisf_cav', fwfisf_cav          )    ! now k-velocity 
    1129             CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav    )    ! now k-velocity 
    1130             CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav    )    ! now k-velocity 
    1131             CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) )    ! now k-velocity 
    1132             CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) )    ! now k-velocity 
     1160            CALL iom_rstput( 0, 0, inum, 'fwfisf_cav', fwfisf_cav          ) 
     1161            CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav    ) 
     1162            CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav    ) 
     1163            CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) 
     1164            CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) 
    11331165            CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) 
    11341166         END IF 
    11351167         IF (ln_isfpar_mlt) THEN 
    1136             CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) )    ! now k-velocity 
    1137             CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par          )    ! now k-velocity 
    1138             CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par    )    ! now k-velocity 
    1139             CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par    )    ! now k-velocity 
    1140             CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) )    ! now k-velocity 
    1141             CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) )    ! now k-velocity 
     1168            CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) 
     1169            CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par          ) 
     1170            CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par    ) 
     1171            CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par    ) 
     1172            CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) 
     1173            CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) 
    11421174            CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) 
    11431175         END IF 
     
    11521184         CALL iom_rstput( 0, 0, inum,  'ahmf', ahmf              )    ! ahmf at v-point 
    11531185      ENDIF 
    1154       CALL iom_rstput( 0, 0, inum, 'sowaflup', emp - rnf         )    ! freshwater budget 
    1155       CALL iom_rstput( 0, 0, inum, 'sohefldo', qsr + qns         )    ! total heat flux 
     1186      DO_2D( 0, 0, 0, 0 ) 
     1187         z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) 
     1188      END_2D 
     1189      CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d               )    ! freshwater budget 
     1190      DO_2D( 0, 0, 0, 0 ) 
     1191         z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) 
     1192      END_2D 
     1193      CALL iom_rstput( 0, 0, inum, 'sohefldo', z2d               )    ! total heat flux 
    11561194      CALL iom_rstput( 0, 0, inum, 'soshfldo', qsr               )    ! solar heat flux 
    11571195      CALL iom_rstput( 0, 0, inum, 'soicecov', fr_i              )    ! ice fraction 
    11581196      CALL iom_rstput( 0, 0, inum, 'sozotaux', utau              )    ! i-wind stress 
    11591197      CALL iom_rstput( 0, 0, inum, 'sometauy', vtau              )    ! j-wind stress 
    1160       IF(  .NOT.ln_linssh  ) THEN              
    1161          CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept        )    !  T-cell depth  
    1162          CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t          )    !  T-cell thickness   
     1198      IF(  .NOT.ln_linssh  ) THEN 
     1199         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     1200           z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm)   ! 3D workspace for qco substitution 
     1201         END_3D 
     1202         CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d            )    !  T-cell depth  
     1203         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     1204           z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm)     ! 3D workspace for qco substitution 
     1205         END_3D 
     1206         CALL iom_rstput( 0, 0, inum, 'vovvle3t', z3d            )    !  T-cell thickness   
    11631207      END IF 
    11641208      IF( ln_wave .AND. ln_sdw ) THEN 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/dom_oce.F90

    r15127 r15349  
    274274      ! 
    275275      ii = ii+1 
    276       ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj), STAT=ierr(ii) ) 
    277          ! 
    278       ii = ii+1 
    279       ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo), STAT=ierr(ii) ) 
    280          ! 
    281       ii = ii+1 
    282276      ALLOCATE( glamt(jpi,jpj) ,    glamu(jpi,jpj) ,  glamv(jpi,jpj) ,  glamf(jpi,jpj) ,     & 
    283277         &      gphit(jpi,jpj) ,    gphiu(jpi,jpj) ,  gphiv(jpi,jpj) ,  gphif(jpi,jpj) ,     & 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domain.F90

    r15127 r15349  
    2020   !!---------------------------------------------------------------------- 
    2121   !!   dom_init      : initialize the space and time domain 
    22    !!   dom_glo       : initialize global domain <--> local domain indices 
    2322   !!   dom_nam       : read and contral domain namelists 
    2423   !!   dom_ctl       : control print for the ocean domain 
     
    124123      !           !==  Reference coordinate system  ==! 
    125124      ! 
    126       CALL dom_glo                      ! global domain versus local domain 
    127125      CALL dom_nam                      ! read namelist ( namrun, namdom ) 
    128126      CALL dom_tile_init                ! Tile domain 
     
    244242      ! 
    245243   END SUBROUTINE dom_init 
    246  
    247  
    248    SUBROUTINE dom_glo 
    249       !!---------------------------------------------------------------------- 
    250       !!                     ***  ROUTINE dom_glo  *** 
    251       !! 
    252       !! ** Purpose :   initialization of global domain <--> local domain indices 
    253       !! 
    254       !! ** Method  : 
    255       !! 
    256       !! ** Action  : - mig , mjg : local  domain indices ==> global domain, including halos, indices 
    257       !!              - mig0, mjg0: local  domain indices ==> global domain, excluding halos, indices 
    258       !!              - mi0 , mi1 : global domain indices ==> local  domain indices 
    259       !!              - mj0 , mj1   (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 
    260       !!---------------------------------------------------------------------- 
    261       INTEGER ::   ji, jj   ! dummy loop argument 
    262       !!---------------------------------------------------------------------- 
    263       ! 
    264       DO ji = 1, jpi                 ! local domain indices ==> global domain indices, including halos 
    265         mig(ji) = ji + nimpp - 1 
    266       END DO 
    267       DO jj = 1, jpj 
    268         mjg(jj) = jj + njmpp - 1 
    269       END DO 
    270       !                              ! local domain indices ==> global domain indices, excluding halos 
    271       ! 
    272       mig0(:) = mig(:) - nn_hls 
    273       mjg0(:) = mjg(:) - nn_hls 
    274       !                              ! global domain, including halos, indices ==> local domain indices 
    275       !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 
    276       !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 
    277       DO ji = 1, jpiglo 
    278         mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) 
    279         mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi   ) ) 
    280       END DO 
    281       DO jj = 1, jpjglo 
    282         mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) 
    283         mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj   ) ) 
    284       END DO 
    285       IF(lwp) THEN                   ! control print 
    286          WRITE(numout,*) 
    287          WRITE(numout,*) 'dom_glo : domain: global <<==>> local ' 
    288          WRITE(numout,*) '~~~~~~~ ' 
    289          WRITE(numout,*) '   global domain:   jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo 
    290          WRITE(numout,*) '   local  domain:   jpi    = ', jpi   , ' jpj    = ', jpj   , ' jpk    = ', jpk 
    291          WRITE(numout,*) 
    292       ENDIF 
    293       ! 
    294    END SUBROUTINE dom_glo 
    295244 
    296245 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/dommsk.F90

    r15127 r15349  
    7373      !!         2 < rn_shlat, strong slip        | in the lateral boundary layer 
    7474      !! 
    75       !!      tmask_i : interior ocean mask at t-point, i.e. excluding duplicated 
    76       !!                rows/lines due to cyclic or North Fold boundaries as well 
    77       !!                as MPP halos. 
    78       !!      tmask_h : halo mask at t-point, i.e. excluding duplicated rows/lines 
    79       !!                due to cyclic or North Fold boundaries as well as MPP halos. 
    80       !! 
    8175      !! ** Action :   tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask  
    8276      !!                         at t-, u-, v- w, wu-, and wv-points (=0. or 1.) 
    8377      !!               fmask   : land/ocean mask at f-point (=0., or =1., or  
    8478      !!                         =rn_shlat along lateral boundaries) 
    85       !!               tmask_i : interior ocean mask  
    86       !!               tmask_h : halo mask 
    87       !!               ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask 
     79      !!               ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask, i.e. at least 1 wet cell in the vertical 
     80      !!               tmask_h : halo mask at t-point, i.e. excluding all duplicated rows/lines 
     81      !!                         due to cyclic or North Fold boundaries as well as MPP halos. 
     82      !!               tmask_i : ssmask * tmask_h 
    8883      !!---------------------------------------------------------------------- 
    8984      INTEGER, DIMENSION(:,:), INTENT(in) ::   k_top, k_bot   ! first and last ocean level 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynldf_lap_blp_lf.F90

    r15127 r15349  
    102102         DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 )                           ! Horizontal slab 
    103103            !                                      ! ahm * e3 * curl  (warning: computed for ji-1,jj-1) 
    104             zcur     = ahmf(ji,jj,jk) * e3f(ji,jj,jk) * r1_e1e2f(ji,jj)               &   ! ahmf already * by fmask    
    105                &       * ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
    106                &       - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) 
    107             zcur_jm1 = ahmf(ji  ,jj-1,jk) * e3f(ji,jj-1,jk) * r1_e1e2f(ji,jj-1)               &   ! ahmf already * by fmask 
     104            zcur     = ahmf(ji  ,jj  ,jk) * e3f(ji  ,jj  ,jk) * r1_e1e2f(ji  ,jj  )               &   ! ahmf already * by fmask    
     105               &       * ( e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
     106               &         - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) 
     107            zcur_jm1 = ahmf(ji  ,jj-1,jk) * e3f(ji  ,jj-1,jk) * r1_e1e2f(ji  ,jj-1)               &   ! ahmf already * by fmask 
    108108               &       * ( e2v(ji+1,jj-1) * pv(ji+1,jj-1,jk) - e2v(ji,jj-1) * pv(ji,jj-1,jk)  & 
    109                &       - e1u(ji,jj) * pu(ji,jj,jk) + e1u(ji,jj-1) * pu(ji,jj-1,jk) ) 
    110             zcur_im1 = ahmf(ji-1,jj,jk) * e3f(ji-1,jj,jk) * r1_e1e2f(ji-1,jj)         &   ! ahmf already * by fmask 
    111                &       * ( e2v(ji,jj) * pv(ji,jj,jk) - e2v(ji-1,jj) * pv(ji-1,jj,jk)  & 
    112                &       - e1u(ji-1,jj+1) * pu(ji-1,jj+1,jk) + e1u(ji-1,jj) * pu(ji-1,jj,jk) ) 
     109               &         - e1u(ji  ,jj  ) * pu(ji  ,jj  ,jk) + e1u(ji,jj-1) * pu(ji,jj-1,jk) ) 
     110            zcur_im1 = ahmf(ji-1,jj  ,jk) * e3f(ji-1,jj  ,jk) * r1_e1e2f(ji-1,jj  )         &   ! ahmf already * by fmask 
     111               &       * ( e2v(ji  ,jj  ) * pv(ji  ,jj  ,jk) - e2v(ji-1,jj) * pv(ji-1,jj,jk)  & 
     112               &         - e1u(ji-1,jj+1) * pu(ji-1,jj+1,jk) + e1u(ji-1,jj) * pu(ji-1,jj,jk) ) 
    113113            !                                      ! ahm * div        (warning: computed for ji,jj) 
    114114            zdiv     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)               &   ! ahmt already * by tmask 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/FLO/flodom.F90

    r15127 r15349  
    371371      REAL(wp) ::   zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt 
    372372      !!--------------------------------------------------------------------- 
    373       !! Statement function 
    374       REAL(wp) ::   fsline 
    375       REAL(wp) ::   psax, psay, psbx, psby, psx, psy 
    376       fsline( psax, psay, psbx, psby, psx, psy ) = psy  * ( psbx - psax )   & 
    377          &                                       - psx  * ( psby - psay )   & 
    378          &                                       + psax *   psby - psay * psbx 
    379       !!--------------------------------------------------------------------- 
    380373       
    381374      ! 4 semi plane defined by the 4 points and including the T point 
     
    412405   END SUBROUTINE flo_findmesh 
    413406 
    414  
     407   FUNCTION fsline( psax, psay, psbx, psby, psx, psy ) 
     408      !! --------------------------------------------------------------------- 
     409      !!                 ***  Function fsline  *** 
     410      !!           
     411      !! ** Purpose : 
     412      !! ** Method  :  
     413      !!---------------------------------------------------------------------- 
     414      REAL(wp) ::   fsline 
     415      REAL(wp), INTENT(in) ::   psax, psay, psbx, psby, psx, psy 
     416      !!--------------------------------------------------------------------- 
     417      fsline = psy  * ( psbx - psax )   & 
     418         &   - psx  * ( psby - psay )   & 
     419         &   + psax *   psby - psay * psbx 
     420      ! 
     421   END FUNCTION fsline 
     422  
    415423   FUNCTION flo_dstnce( pla1, phi1, pla2, phi2 ) 
    416424      !! ------------------------------------------------------------- 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/IOM/prtctl.F90

    r15127 r15349  
    6161            &                          tab3d_1 = REAL(tab3d_1, 2*wp),                           tab3d_2 =    REAL(tab3d_2, 2*wp), & 
    6262            &           mask1 = mask1, mask2 = mask2, & 
    63             &           clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 ) 
     63            &           clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim ) 
    6464      ELSEIF( PRESENT(tab2d_1) ) THEN      
    6565         CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0,   & 
     
    7171            &                          tab3d_1 =    REAL(tab3d_1, 2*wp),  & 
    7272            &           mask1 = mask1,  & 
    73             &           clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) 
     73            &           clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) 
    7474      ELSEIF( PRESENT(tab4d_1) ) THEN      
    7575         CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0,   & 
    7676            &                                        tab4d_1 =    REAL(tab4d_1, 2*wp),  & 
    7777            &           mask1 = mask1,  & 
    78             &           clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) 
     78            &           clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) 
    7979      ENDIF 
    8080 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/IOM/restart.F90

    r15127 r15349  
    162162      ! 
    163163      IF( .NOT.ln_diurnal_only ) THEN 
    164          CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , ssh(:,:        ,Kbb) )     ! before fields 
    165          CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb) ) 
    166          CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vv(:,:,:       ,Kbb) ) 
    167          IF( .NOT.lk_SWE ) THEN 
    168             CALL iom_rstput( kt, nitrst, numrow, 'tb'  , ts(:,:,:,jp_tem,Kbb) ) 
    169             CALL iom_rstput( kt, nitrst, numrow, 'sb'  , ts(:,:,:,jp_sal,Kbb) ) 
    170          ENDIF 
     164         CALL iom_rstput( kt, nitrst, numrow, 'sshb', ssh(:,:        ,Kbb) )     ! before fields 
     165         CALL iom_rstput( kt, nitrst, numrow, 'ub'  , uu(:,:,:       ,Kbb) ) 
     166         CALL iom_rstput( kt, nitrst, numrow, 'vb'  , vv(:,:,:       ,Kbb) ) 
     167         CALL iom_rstput( kt, nitrst, numrow, 'tb'  , ts(:,:,:,jp_tem,Kbb) ) 
     168         CALL iom_rstput( kt, nitrst, numrow, 'sb'  , ts(:,:,:,jp_sal,Kbb) ) 
    171169         ! 
    172170#if ! defined key_RK3 
    173          CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , ssh(:,:        ,Kmm) )     ! now fields 
    174          CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm) ) 
    175          CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vv(:,:,:       ,Kmm) ) 
    176          IF( .NOT.lk_SWE ) THEN 
    177             CALL iom_rstput( kt, nitrst, numrow, 'tn'  , ts(:,:,:,jp_tem,Kmm) ) 
    178             CALL iom_rstput( kt, nitrst, numrow, 'sn'  , ts(:,:,:,jp_sal,Kmm) ) 
    179             CALL iom_rstput( kt, nitrst, numrow, 'rhop', rhop                 ) 
    180          ENDIF 
     171         CALL iom_rstput( kt, nitrst, numrow, 'sshn', ssh(:,:        ,Kmm) )     ! now fields 
     172         CALL iom_rstput( kt, nitrst, numrow, 'un'  , uu(:,:,:       ,Kmm) ) 
     173         CALL iom_rstput( kt, nitrst, numrow, 'vn'  , vv(:,:,:       ,Kmm) ) 
     174         CALL iom_rstput( kt, nitrst, numrow, 'tn'  , ts(:,:,:,jp_tem,Kmm) ) 
     175         CALL iom_rstput( kt, nitrst, numrow, 'sn'  , ts(:,:,:,jp_sal,Kmm) ) 
     176         IF( .NOT.lk_SWE )   CALL iom_rstput( kt, nitrst, numrow, 'rhop', rhop ) 
    181177#endif 
    182178      ENDIF 
     
    286282      !                             !*  Read Kbb fields   (NB: in RK3 Kmm = Kbb = Nbb) 
    287283      IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields read in the restart file' 
    288       CALL iom_get( numror, jpdom_auto, 'ub'   , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
    289       CALL iom_get( numror, jpdom_auto, 'vb'   , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
    290       IF( .NOT.lk_SWE ) THEN 
    291          CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
    292          CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
    293       ENDIF 
     284      CALL iom_get( numror, jpdom_auto, 'ub', uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
     285      CALL iom_get( numror, jpdom_auto, 'vb', vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
     286      CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
     287      CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
    294288#else 
    295289      !                             !*  Read Kmm fields   (MLF only) 
    296290      IF(lwp) WRITE(numout,*)    '           Kmm u, v and T-S fields read in the restart file' 
    297       CALL iom_get( numror, jpdom_auto, 'un'   , uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
    298       CALL iom_get( numror, jpdom_auto, 'vn'   , vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
    299       IF( .NOT.lk_SWE ) THEN 
    300          CALL iom_get( numror, jpdom_auto, 'tn', ts(:,:,:,jp_tem,Kmm) ) 
    301          CALL iom_get( numror, jpdom_auto, 'sn', ts(:,:,:,jp_sal,Kmm) ) 
    302       ENDIF 
     291      CALL iom_get( numror, jpdom_auto, 'un', uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
     292      CALL iom_get( numror, jpdom_auto, 'vn', vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
     293      CALL iom_get( numror, jpdom_auto, 'tn', ts(:,:,:,jp_tem,Kmm) ) 
     294      CALL iom_get( numror, jpdom_auto, 'sn', ts(:,:,:,jp_sal,Kmm) ) 
    303295      ! 
    304296      IF( l_1st_euler ) THEN        !*  Euler restart   (MLF only) 
     
    306298         uu(:,:,:  ,Kbb) = uu(:,:,:  ,Kmm)         ! all before fields set to now values 
    307299         vv(:,:,:  ,Kbb) = vv(:,:,:  ,Kmm) 
    308          IF( .NOT.lk_SWE ) ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) 
     300         ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) 
    309301         ! 
    310302      ELSE                          !* Leap frog restart   (MLF only) 
    311303         IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields read in the restart file' 
    312          CALL iom_get( numror, jpdom_auto, 'ub'   , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
    313          CALL iom_get( numror, jpdom_auto, 'vb'   , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
    314          IF( .NOT.lk_SWE ) THEN 
    315             CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
    316             CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
    317          ENDIF 
     304         CALL iom_get( numror, jpdom_auto, 'ub', uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
     305         CALL iom_get( numror, jpdom_auto, 'vb', vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
     306         CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
     307         CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
    318308      ENDIF 
    319309#endif 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ISF/isfcav.F90

    r15127 r15349  
    170170         ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp 
    171171      END_2D 
     172      CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_wp) 
    172173      ! 
    173174      ! output fluxes 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_lnk_neicoll_generic.h90

    r15127 r15349  
    144144      iScnt(:) = PACK( iszall, mask = llsend )                                       ! ok if mask = .false. 
    145145      iRcnt(:) = PACK( iszall, mask = llrecv ) 
    146       iSdpl(1) = 0 
     146      IF( iszS > 0 )   iSdpl(1) = 0 
    147147      DO jn = 2,iszS 
    148148         iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1)   ! with _alltoallv: in units of sendtype 
    149149      END DO 
    150       iRdpl(1) = 0 
     150      IF( iszR > 0 )   iRdpl(1) = 0 
    151151      DO jn = 2,iszR 
    152152         iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1)   ! with _alltoallv: in units of sendtype 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90

    r15127 r15349  
    123123      !cd     sides:     west  east south north      ;   corners: so-we, so-ea, no-we, no-ea 
    124124      isizei(1:4) = (/ ihls, ihls,  ipi,  ipi /)   ;   isizei(5:8) = ihls              ! i- count 
    125       isizej(1:4) = (/  ipj,  ipj, ihls, ihls /)   ;   isizej(5:8) = ihls              ! j- count 
     125      isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /)   ;   isizej(5:8) = ihls              ! j- count 
    126126      ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /)   ;   ishtSi(5:8) = ishtSi( iwewe )   ! i- shift send data 
    127       ishtSj(1:4) = (/ ip0j, ip0j, ip1j, im1j /)   ;   ishtSj(5:8) = ishtSj( issnn )   ! j- shift send data 
     127      ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /)   ;   ishtSj(5:8) = ishtSj( issnn )   ! j- shift send data 
    128128      ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /)   ;   ishtRi(5:8) = ishtRi( iwewe )   ! i- shift received data location 
    129       ishtRj(1:4) = (/ ip0j, ip0j, ip0j, im0j /)   ;   ishtRj(5:8) = ishtRj( issnn )   ! j- shift received data location 
     129      ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /)   ;   ishtRj(5:8) = ishtRj( issnn )   ! j- shift received data location 
    130130      ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /)   ;   ishtPi(5:8) = ishtPi( iwewe )   ! i- shift data used for periodicity 
    131       ishtPj(1:4) = (/ ip0j, ip0j, im1j, ip1j /)   ;   ishtPj(5:8) = ishtPj( issnn )   ! j- shift data used for periodicity 
     131      ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /)   ;   ishtPj(5:8) = ishtPj( issnn )   ! j- shift data used for periodicity 
    132132      ! 
    133133      ! -------------------------------- ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_nfd_generic.h90

    r14448 r15349  
    2929            SELECT CASE ( cd_nat(jf) ) 
    3030            CASE ( 'T' , 'W' )                         ! T-, W-point 
    31                DO jl = 1, ipl; DO jk = 1, ipk 
     31               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    3232                  ! 
    3333                  ! last khls lines (from ipj to ipj-khls+1) : full 
     
    5353                     DO ji = 1, 1                 ! point ipi - khls + 1 
    5454                        ii1 = ipi - khls + ji 
    55                         ii2 =          khls + ji 
     55                        ii2 =       khls + ji 
    5656                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    5757                     END DO 
     
    8484               END DO; END DO 
    8585            CASE ( 'U' )                               ! U-point 
    86                DO jl = 1, ipl; DO jk = 1, ipk 
     86               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    8787                  ! 
    8888                  ! last khls lines (from ipj to ipj-khls+1) : full 
     
    103103                     DO ji = 1, khls              ! last khls points 
    104104                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
    105                         ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     105                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
    106106                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    107107                     END DO 
     
    129129               END DO; END DO 
    130130            CASE ( 'V' )                               ! V-point 
    131                DO jl = 1, ipl; DO jk = 1, ipk 
     131               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    132132                  ! 
    133133                  ! last khls+1 lines (from ipj to ipj-khls) : full 
     
    153153                     DO ji = 1, 1                 ! point ipi - khls + 1 
    154154                        ii1 = ipi - khls + ji 
    155                         ii2 =          khls + ji 
     155                        ii2 =       khls + ji 
    156156                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    157157                     END DO 
     
    165165               END DO; END DO 
    166166            CASE ( 'F' )                               ! F-point 
    167                DO jl = 1, ipl; DO jk = 1, ipk 
     167               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    168168                  ! 
    169169                  ! last khls+1 lines (from ipj to ipj-khls) : full 
     
    184184                     DO ji = 1, khls              ! last khls points 
    185185                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
    186                         ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     186                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
    187187                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    188188                     END DO 
     
    198198            SELECT CASE ( cd_nat(jf) ) 
    199199            CASE ( 'T' , 'W' )                         ! T-, W-point 
    200                DO jl = 1, ipl; DO jk = 1, ipk 
     200               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    201201                  ! 
    202202                  ! first: line number ipj-khls : 3 points 
     
    212212                     DO ji = 1, 1                 ! points ipi - khls 
    213213                        ii1 = ipi - khls + ji - 1 
    214                         ii2 =          khls + ji 
     214                        ii2 =       khls + ji 
    215215                        ptab(jf)%pt4d(ii1,ij1,jk,jl) =            ptab(jf)%pt4d(ii2,ij2,jk,jl)   ! Warning: pb with sign... 
    216216                     END DO 
     
    240240                     DO ji = 1, khls              ! last khls points 
    241241                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
    242                         ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     242                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
    243243                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    244244                     END DO 
     
    247247               END DO; END DO 
    248248            CASE ( 'U' )                               ! U-point 
    249                DO jl = 1, ipl; DO jk = 1, ipk 
     249               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    250250                  ! 
    251251                  ! last khls lines (from ipj to ipj-khls+1) : full 
     
    283283               END DO; END DO 
    284284            CASE ( 'V' )                               ! V-point 
    285                DO jl = 1, ipl; DO jk = 1, ipk 
     285               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    286286                  ! 
    287287                  ! last khls lines (from ipj to ipj-khls+1) : full 
     
    302302                     DO ji = 1, khls            ! last khls points 
    303303                        ii1 = ipi - khls + ji          ! ends at: ipi - khls + khls = ipi 
    304                         ii2 = ipi - khls + 1 - ji      ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     304                        ii2 = ipi - khls - ji + 1      ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
    305305                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    306306                     END DO 
     
    328328               END DO; END DO 
    329329            CASE ( 'F' )                               ! F-point 
    330                DO jl = 1, ipl; DO jk = 1, ipk 
     330               DO jl = 1, ipl   ;  DO jk = 1, ipk 
    331331                  ! 
    332332                  ! last khls lines (from ipj to ipj-khls+1) : full 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbcnfd.F90

    r14448 r15349  
    1010 
    1111   !!---------------------------------------------------------------------- 
    12    !!   lbc_nfd       : generic interface for lbc_nfd_3d and lbc_nfd_2d routines 
    13    !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    14    !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    15    !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and  
    16    !!                            lbc_nfd_nogather_2d routines (designed for use 
    17    !!                            with ln_nnogather to avoid global width arrays 
    18    !!                            mpi all gather operations) 
     12   !!   lbc_nfd       : generic interface for lbc_nfd_sp and lbc_nfd_dp routines that is doing the north fold in a non-mpi case  
     13   !!   mpp_nfd       : generic interface for mpp_nfd_sp and mpp_nfd_dp routines that will use lbc_nfd directly or indirectly 
    1914   !!---------------------------------------------------------------------- 
    2015   USE dom_oce        ! ocean space and time domain  
     
    3631      MODULE PROCEDURE   mpp_nfd_sp, mpp_nfd_dp 
    3732   END INTERFACE 
    38  
    39    INTERFACE lbc_nfd_nogather   ! called by mpp_nfd 
    40       MODULE PROCEDURE   lbc_nfd_nogather_sp, lbc_nfd_nogather_dp 
    41    END INTERFACE 
    4233    
    4334   PUBLIC   mpp_nfd            ! mpi north fold conditions 
    4435   PUBLIC   lbc_nfd            ! north fold conditions 
    45    PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case) 
    4636 
    47    INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
    48    INTEGER, PUBLIC                       ::   nsndto                     !: 
    49    INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate 
    50    INTEGER, PUBLIC                       ::   ijpj 
    51  
     37   INTEGER, PUBLIC                               :: nfd_nbnei 
     38   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:  ) :: nfd_rknei 
     39   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd 
     40   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd 
     41    
    5242   !!---------------------------------------------------------------------- 
    5343   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
     
    5949   !!---------------------------------------------------------------------- 
    6050   !!                   ***  routine lbc_nfd_[sd]p  *** 
    61    !!               ***  routine lbc_nfd_nogather_[sd]p  *** 
    6251   !!                   ***  routine lbc_nfd_ext_[sd]p  *** 
    6352   !!---------------------------------------------------------------------- 
     
    7564#define PRECISION sp 
    7665#  include "lbc_nfd_generic.h90" 
    77 #  include "lbc_nfd_nogather_generic.h90" 
    7866#  include "lbc_nfd_ext_generic.h90" 
    7967#undef PRECISION 
     
    8371#define PRECISION dp 
    8472#  include "lbc_nfd_generic.h90" 
    85 #  include "lbc_nfd_nogather_generic.h90" 
    8673#  include "lbc_nfd_ext_generic.h90" 
    8774#undef PRECISION 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lib_mpp.F90

    r15127 r15349  
    4949   !!   mppsync       : 
    5050   !!   mppstop       : 
    51    !!   mpp_ini_north : initialisation of north fold 
     51   !!   mpp_ini_northgather : initialisation of north fold with gathering of the communications 
    5252   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 
    5353   !!   mpp_bcast_nml : broadcast/receive namelist character buffer from reading process to all others 
     
    6464   PUBLIC   ctl_stop, ctl_warn, ctl_opn, ctl_nam, load_nml 
    6565   PUBLIC   mpp_start, mppstop, mppsync, mpp_comm_free 
    66    PUBLIC   mpp_ini_north 
     66   PUBLIC   mpp_ini_northgather 
    6767   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    6868   PUBLIC   mpp_delay_max, mpp_delay_sum, mpp_delay_rcv 
     
    11521152 
    11531153 
    1154    SUBROUTINE mpp_ini_north 
    1155       !!---------------------------------------------------------------------- 
    1156       !!               ***  routine mpp_ini_north  *** 
     1154   SUBROUTINE mpp_ini_northgather 
     1155      !!---------------------------------------------------------------------- 
     1156      !!               ***  routine mpp_ini_northgather  *** 
    11571157      !! 
    11581158      !! ** Purpose :   Initialize special communicator for north folding 
     
    12101210      ! 
    12111211#endif 
    1212    END SUBROUTINE mpp_ini_north 
     1212   END SUBROUTINE mpp_ini_northgather 
    12131213 
    12141214 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mpp_nfd_generic.h90

    r14448 r15349  
    1010      ! 
    1111      LOGICAL  ::   ll_add_line 
    12       INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices 
     12      INTEGER  ::   ji,  jj,  jk,  jl, jf, jr, jg, jn   ! dummy loop indices 
    1313      INTEGER  ::   ipi, ipj, ipj2, ipk, ipl, ipf   ! dimension of the input array 
    14       INTEGER  ::   imigr, iihom, ijhom             ! local integers 
    1514      INTEGER  ::   ierr, ibuffsize, iis0, iie0, impp 
    16       INTEGER  ::   ii1, ii2, ij1, ij2 
    17       INTEGER  ::   ipimax, i0max 
     15      INTEGER  ::   ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin 
     16      INTEGER  ::   i0max 
    1817      INTEGER  ::   ij, iproc, ipni, ijnr 
    19       INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    20       INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    21       !                                                    ! Workspace for message transfers avoiding mpi_allgather 
    22       INTEGER                             ::   ipj_b       ! sum of lines for all multi fields 
    23       INTEGER                             ::   i012        ! 0, 1 or 2 
    24       INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_s  ! position of sent lines 
    25       INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_b  ! position of buffer lines 
    26       INTEGER , DIMENSION(:)          , ALLOCATABLE ::   ipj_s ! number of sent lines 
    27       REAL(PRECISION), DIMENSION(:,:,:,:)    , ALLOCATABLE ::   ztabb, ztabr, ztabw  ! buffer, receive and work arrays 
     18      INTEGER, DIMENSION (:), ALLOCATABLE ::   ireq_s, ireq_r   ! for mpi_isend when avoiding mpi_allgather 
     19      INTEGER                             ::   ipjtot           ! sum of lines for all multi fields 
     20      INTEGER                             ::   i012             ! 0, 1 or 2 
     21      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   ijsnd  ! j-position of sent lines for each field 
     22      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   ijbuf  ! j-position of send buffer lines for each field 
     23      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   ijrcv  ! j-position of recv buffer lines for each field 
     24      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   ii1st, iiend 
     25      INTEGER , DIMENSION(:)          , ALLOCATABLE ::   ipjfld ! number of sent lines for each field 
     26      REAL(PRECISION), DIMENSION(:,:,:,:)    , ALLOCATABLE ::   zbufs  ! buffer, receive and work arrays 
     27      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   zbufr  ! buffer, receive and work arrays 
    2828      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc 
    2929      REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthglo 
     
    6262         ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 
    6363          
    64          ALLOCATE(ipj_s(ipf))                ! how many lines do we exchange? 
     64         ALLOCATE(ipjfld(ipf))                 ! how many lines do we exchange for each field? 
    6565         IF( ll_add_line ) THEN 
    66             DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    67                ipj_s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )  
     66            DO jf = 1, ipf                     ! Loop over the number of arrays to be processed 
     67               ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 
    6868            END DO 
    6969         ELSE 
    70             ipj_s(:) = khls 
     70            ipjfld(:) = khls 
    7171         ENDIF 
    7272          
    73          ipj   = MAXVAL(ipj_s(:))            ! Max 2nd dimension of message transfers 
    74          ipj_b = SUM(   ipj_s(:))            ! Total number of lines to be exchanged 
    75          ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 
     73         ipj    = MAXVAL(ipjfld(:))            ! Max 2nd dimension of message transfers 
     74         ipjtot = SUM(   ipjfld(:))            ! Total number of lines to be exchanged 
    7675 
    7776         ! Index of modifying lines in input 
     77         ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) 
     78 
    7879         ij1 = 0 
    79          DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    80             ! 
     80         DO jf = 1, ipf                        ! Loop over the number of arrays to be processed 
     81            ! 
     82            DO jj = 1, khls   ! first khls lines (starting from top) must be fully defined 
     83               ii1st(jj, jf) = 1 
     84               iiend(jj, jf) = jpi 
     85            END DO 
     86            ! 
     87            ! what do we do with line khls+1 (starting from top) 
    8188            IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot 
    8289               SELECT CASE ( cd_nat(jf) ) 
    83                CASE ( 'T', 'W', 'U' )   ;   i012 = 1   ! T-, U-, W-point 
    84                CASE ( 'V', 'F'      )   ;   i012 = 2   ! V-, F-point 
     90               CASE ('T','W')   ;   i012 = 1   ;   ii1st(khls+1, jf) = mi0(jpiglo/2+2)   ;   iiend(khls+1, jf) = mi1(jpiglo-khls) 
     91               CASE ('U'    )   ;   i012 = 1   ;   ii1st(khls+1, jf) = mi0(jpiglo/2+1)   ;   iiend(khls+1, jf) = mi1(jpiglo-khls) 
     92               CASE ('V'    )   ;   i012 = 2   ;   ii1st(khls+1, jf) = 1                 ;   iiend(khls+1, jf) = jpi 
     93               CASE ('F'    )   ;   i012 = 2   ;   ii1st(khls+1, jf) = 1                 ;   iiend(khls+1, jf) = jpi 
    8594               END SELECT 
    8695            ENDIF 
    8796            IF( c_NFtype == 'F' ) THEN          ! *  North fold  F-point pivot 
    8897               SELECT CASE ( cd_nat(jf) ) 
    89                CASE ( 'T', 'W', 'U' )   ;   i012 = 0   ! T-, U-, W-point 
    90                CASE ( 'V', 'F'      )   ;   i012 = 1   ! V-, F-point 
     98               CASE ('T','W')   ;   i012 = 0   ! we don't touch line khls+1 
     99               CASE ('U'    )   ;   i012 = 0   ! we don't touch line khls+1 
     100               CASE ('V'    )   ;   i012 = 1   ;   ii1st(khls+1, jf) = mi0(jpiglo/2+1)   ;   iiend(khls+1, jf) = mi1(jpiglo-khls  ) 
     101               CASE ('F'    )   ;   i012 = 1   ;   ii1st(khls+1, jf) = mi0(jpiglo/2+1)   ;   iiend(khls+1, jf) = mi1(jpiglo-khls-1) 
    91102               END SELECT 
    92103            ENDIF 
    93                ! 
    94             DO jj = 1, ipj_s(jf) 
     104            ! 
     105            DO jj = 1, ipjfld(jf) 
    95106               ij1 = ij1 + 1 
    96                jj_b(jj,jf) = ij1 
    97                jj_s(jj,jf) = jpj - 2*khls + jj - i012 
     107               ijsnd(jj,jf) = jpj - 2*khls + jj - i012   ! sent lines (from bottom of sent lines) 
     108               ijbuf(jj,jf) = ij1                        ! gather all lines in the snd/rcv buffers 
     109               ijrcv(jj,jf) = jpj - jj + 1               ! recv lines (from the top -> reverse order for jj) 
    98110            END DO 
    99111            ! 
    100112         END DO 
    101113         ! 
    102          ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) )   ! store all the data to be sent in a buffer array 
    103          ibuffsize = jpimax * ipj_b * ipk * ipl 
    104          ! 
     114         i0max = jpimax - 2 * khls                                    ! we are not sending the halos 
     115         ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) )   ! store all the data to be sent in a buffer array 
     116         ibuffsize = i0max * ipjtot * ipk * ipl 
     117         ! 
     118         ! fill the send buffer with all the lines 
    105119         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
    106             DO jj = 1, ipj_s(jf) 
    107                ij1 = jj_b(jj,jf) 
    108                ij2 = jj_s(jj,jf) 
    109                DO ji = 1, jpi 
    110                   ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
    111                END DO 
    112                DO ji = jpi+1, jpimax 
    113                   ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION)   ! avoid sending uninitialized values (make sure we don't use it) 
     120            DO jj = 1, ipjfld(jf) 
     121               ij1 = ijbuf(jj,jf) 
     122               ij2 = ijsnd(jj,jf) 
     123               DO ji = Nis0, Nie0       ! should not use any other value 
     124                  iib = ji - Nis0 + 1 
     125                  zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
     126               END DO 
     127               DO ji = Ni_0+1, i0max    ! avoid sending uninitialized values (make sure we don't use it) 
     128                  zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION)   ! make sure we don't use it... 
    114129               END DO 
    115130            END DO 
     
    119134         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    120135         ! 
    121          ! send the data as soon as possible 
    122          DO jr = 1, nsndto 
    123             iproc = nfproc(isendto(jr)) 
     136         ! send the same buffer data to all neighbourgs as soon as possible 
     137         DO jn = 1, nfd_nbnei 
     138            iproc = nfd_rknei(jn) 
    124139            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    125140#if ! defined key_mpi_off 
    126                CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr ) 
     141               CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) 
    127142#endif 
     143            ELSE 
     144               ireq_s(jn) = MPI_REQUEST_NULL 
    128145            ENDIF 
    129146         END DO 
    130147         ! 
    131          ipimax = jpimax * jpmaxngh 
    132          ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) )  
    133          ! 
    134          DO jr = 1, nsndto 
    135             ! 
    136             ipni  = isendto(jr) 
    137             iproc = nfproc(ipni) 
    138             ipi   = nfjpi (ipni) 
    139             ! 
    140             IF( ipni ==   1  ) THEN   ;   iis0 =   1          ! domain  left side: as e-w comm already done -> from 1st column 
    141             ELSE                      ;   iis0 =   1 + khls   ! default: -> from inner domain  
    142             ENDIF 
    143             IF( ipni == jpni ) THEN   ;   iie0 = ipi          ! domain right side: as e-w comm already done -> until last column 
    144             ELSE                      ;   iie0 = ipi - khls   ! default: -> until inner domain  
    145             ENDIF 
    146             impp = nfimpp(ipni) - nfimpp(isendto(1)) 
     148         ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) )  
     149         ! 
     150         DO jn = 1, nfd_nbnei 
     151            ! 
     152            iproc = nfd_rknei(jn) 
    147153            ! 
    148154            IF(           iproc == -1 ) THEN   ! No neighbour (land proc that was suppressed) 
    149155               ! 
     156               ireq_r(jn) = MPI_REQUEST_NULL                ! no message to be received 
     157               zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION)   ! default: define it and make sure we don't use it... 
    150158               SELECT CASE ( kfillmode ) 
    151                CASE ( jpfillnothing )               ! no filling  
    152                CASE ( jpfillcopy    )               ! filling with inner domain values 
     159               CASE ( jpfillnothing )                       ! no filling  
     160               CASE ( jpfillcopy    )                       ! filling with inner domain values 
    153161                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
    154                      DO jj = 1, ipj_s(jf) 
    155                         ij1 = jj_b(jj,jf) 
    156                         ij2 = jj_s(jj,jf) 
    157                         DO ji = iis0, iie0 
    158                            ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl)   ! chose to take the 1st iner domain point 
    159                         END DO 
     162                     DO jj = 1, ipjfld(jf) 
     163                        ij1 = ijbuf(jj,jf) 
     164                        ij2 = ijsnd(jj,jf)                                      ! we will use only the first value, see init_nfdcom 
     165                        zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl)   ! chose to take the 1st inner domain point 
    160166                     END DO 
    161167                  END DO   ;   END DO   ;   END DO 
    162                CASE ( jpfillcst     )               ! filling with constant value 
    163                   DO jl = 1, ipl   ;   DO jk = 1, ipk 
    164                      DO jj = 1, ipj_b 
    165                         DO ji = iis0, iie0 
    166                            ztabr(impp+ji,jj,jk,jl) = pfillval 
    167                         END DO 
    168                      END DO 
    169                   END DO   ;   END DO 
     168               CASE ( jpfillcst     )                       ! filling with constant value 
     169                  zbufr(1,:,:,:,jn) = pfillval              ! we will use only the first value, see init_nfdcom 
    170170               END SELECT 
    171171               ! 
    172172            ELSE IF( iproc == narea-1 ) THEN   ! get data from myself! 
    173173               ! 
     174               ireq_r(jn) = MPI_REQUEST_NULL                ! no message to be received 
    174175               DO jf = 1, ipf   ;   DO jl = 1, ipl  ;   DO jk = 1, ipk 
    175                   DO jj = 1, ipj_s(jf) 
    176                      ij1 = jj_b(jj,jf) 
    177                      ij2 = jj_s(jj,jf) 
    178                      DO ji = iis0, iie0 
    179                         ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
     176                  DO jj = 1, ipjfld(jf) 
     177                     ij1 = ijbuf(jj,jf) 
     178                     ij2 = ijsnd(jj,jf) 
     179                     DO ji = Nis0, Nie0                     ! should not use any other value 
     180                        iib = ji - Nis0 + 1 
     181                        zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
    180182                     END DO 
    181183                  END DO 
     
    183185               ! 
    184186            ELSE                               ! get data from a neighbour trough communication 
    185                !   
    186187#if ! defined key_mpi_off 
    187                CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr ) 
     188               CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) 
    188189#endif 
    189                DO jl = 1, ipl   ;   DO jk = 1, ipk 
    190                   DO jj = 1, ipj_b 
    191                      DO ji = iis0, iie0 
    192                         ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 
    193                      END DO 
    194                   END DO 
    195                END DO   ;   END DO 
    196                 
    197             ENDIF 
    198             ! 
    199          END DO   ! nsndto 
     190            ENDIF 
     191            ! 
     192         END DO   ! nfd_nbnei 
     193         ! 
     194         CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr)   ! wait for all Irecv 
    200195         ! 
    201196         IF( ln_timing ) CALL tic_tac(.FALSE.) 
     
    204199         ! 
    205200         DO jf = 1, ipf 
    206             ij1 = jj_b(       1 ,jf) 
    207             ij2 = jj_b(ipj_s(jf),jf) 
    208             CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 
    209          END DO 
    210          ! 
    211          DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 
    212          ! 
    213          DO jr = 1,nsndto 
    214             iproc = nfproc(isendto(jr)) 
    215             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    216                CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err )   ! put the wait at the very end just before the deallocate 
    217             ENDIF 
    218          END DO 
    219          DEALLOCATE( ztabb ) 
     201            ! 
     202            SELECT CASE ( cd_nat(jf) )     ! which grid number? 
     203            CASE ('T','W')   ;   iig = 1   ! T-, W-point 
     204            CASE ('U')       ;   iig = 2   ! U-point 
     205            CASE ('V')       ;   iig = 3   ! V-point 
     206            CASE ('F')       ;   iig = 4   ! F-point 
     207            END SELECT 
     208            ! 
     209            DO jl = 1, ipl   ;   DO jk = 1, ipk 
     210               ! 
     211               ! if T point with F-point pivot : must be done first 
     212               !    --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless)  
     213               IF( c_NFtype == 'F' .AND. iig == 1 ) THEN 
     214                  ij1 = jpj - khls     ! j-index in the receiving array 
     215                  ij2 = 1              ! only 1 line in the buffer 
     216                  DO ji = mi0(khls), mi1(khls) 
     217                     iib = nfd_jisnd(mi0(       khls),iig)   ! i-index in the buffer 
     218                     iin = nfd_rksnd(mi0(       khls),iig)   ! neigbhour-index in the buffer 
     219                     IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing )   CYCLE 
     220                     ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin)   ! no psgn(jf) 
     221                  END DO 
     222                  DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) 
     223                     iib = nfd_jisnd(mi0( jpiglo/2+1),iig)   ! i-index in the buffer 
     224                     iin = nfd_rksnd(mi0( jpiglo/2+1),iig)   ! neigbhour-index in the buffer 
     225                     IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing )   CYCLE 
     226                     ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin)   ! no psgn(jf) 
     227                  END DO 
     228                  DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) 
     229                     iib = nfd_jisnd(mi0(jpiglo-khls),iig)   ! i-index in the buffer 
     230                     iin = nfd_rksnd(mi0(jpiglo-khls),iig)   ! neigbhour-index in the buffer 
     231                     IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing )   CYCLE 
     232                     ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin)   ! no psgn(jf) 
     233                  END DO 
     234               ENDIF 
     235               ! 
     236               ! Apply the North pole folding. 
     237               DO jj = 1, ipjfld(jf)   ! for all lines to be exchanged for this field 
     238                  ij1 = ijrcv(jj,jf)   ! j-index in the receiving array 
     239                  ij2 = ijbuf(jj,jf)   ! j-index in the buffer 
     240                  iis = ii1st(jj,jf)   ! stating i-index in the receiving array 
     241                  iie = iiend(jj,jf)   !  ending i-index in the receiving array 
     242                  DO ji = iis, iie  
     243                     iib = nfd_jisnd(ji,iig)   ! i-index in the buffer 
     244                     iin = nfd_rksnd(ji,iig)   ! neigbhour-index in the buffer 
     245                     IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing )   CYCLE 
     246                     ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) 
     247                  END DO 
     248               END DO 
     249               ! 
     250               ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) 
     251               IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot 
     252                  IF(     iig <= 2 ) THEN   ;   iis = mi0(1)   ;   iie = mi1(khls)   ! 'T','W','U': update west halo 
     253                  ELSE                      ;   iis = 1        ;   iie = 0           ! 'V','F'    : full line already exchanged 
     254                  ENDIF 
     255               ENDIF 
     256               IF( c_NFtype == 'F' ) THEN          ! *  North fold  F-point pivot 
     257                  IF(     iig <= 2 ) THEN   ;   iis = 1        ;   iie = 0           ! 'T','W','U': nothing to do 
     258                  ELSEIF( iig == 3 ) THEN   ;   iis = mi0(1)   ;   iie = mi1(khls)   ! 'V'        : update west halo 
     259                  ELSEIF( khls > 1 ) THEN   ;   iis = mi0(1)   ;   iie = mi1(khls-1) ! 'F' and khls > 1 
     260                  ELSE                      ;   iis = 1        ;   iie = 0           ! 'F' and khls == 1 : nothing to do 
     261                  ENDIF 
     262               ENDIF 
     263               jj  = ipjfld(jf)     ! only for the last line of this field 
     264               ij1 = ijrcv(jj,jf)   ! j-index in the receiving array 
     265               ij2 = ijbuf(jj,jf)   ! j-index in the buffer 
     266               DO ji = iis, iie 
     267                  iib = nfd_jisnd(ji,iig)   ! i-index in the buffer 
     268                  iin = nfd_rksnd(ji,iig)   ! neigbhour-index in the buffer 
     269                  IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing )   CYCLE 
     270                  ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) 
     271               END DO 
     272               !                
     273            END DO   ;   END DO   ! ipl   ; ipk 
     274            !                
     275         END DO   ! ipf 
     276        
     277         ! 
     278         DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) 
     279         ! 
     280         CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr)   ! wait for all Isend 
     281         ! 
     282         DEALLOCATE( zbufs, ireq_s ) 
    220283         ! 
    221284      ELSE                             !==  allgather exchanges  ==! 
     
    265328              ! 
    266329               SELECT CASE ( kfillmode ) 
    267                CASE ( jpfillnothing )               ! no filling  
     330               CASE ( jpfillnothing )               ! no filling 
     331                  CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') 
    268332               CASE ( jpfillcopy    )               ! filling with inner domain values 
    269333                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     
    329393         DEALLOCATE( ztabglo ) 
    330394         ! 
    331       ENDIF   ! l_north_nogather 
     395      ENDIF   ! ln_nnogather 
    332396      ! 
    333397   END SUBROUTINE mpp_nfd_/**/PRECISION 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mppini.F90

    r15127 r15349  
    2323   USE bdy_oce        ! open BounDarY 
    2424   ! 
    25    USE lbcnfd  , ONLY : isendto, nsndto ! Setup of north fold exchanges 
     25   USE lbcnfd        ! Setup of north fold exchanges 
    2626   USE lib_mpp        ! distribued memory computing library 
    2727   USE iom            ! nemo I/O library 
     
    168168      IF(lwp) THEN 
    169169            WRITE(numout,*) '   Namelist nammpp' 
    170          IF( jpni < 1 .OR. jpnj < 1  ) THEN 
     170         IF( jpni < 1 .OR. jpnj < 1 ) THEN 
    171171            WRITE(numout,*) '      jpni and jpnj will be calculated automatically' 
    172172         ELSE 
     
    331331      njmpp = ijmppt(ii,ij) 
    332332      ! 
    333       CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 
     333      CALL init_doloop    ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 
     334      CALL init_locglo    ! define now functions needed to convert indices from/to global to/from local domains 
    334335      ! 
    335336      IF(lwp) THEN 
     
    503504         WRITE(numout,*) '      mpi nei no-we = ', mpinei(jpnw)  , '   mpi nei no-ea = ', mpinei(jpne) 
    504505      ENDIF 
    505       !                          ! Prepare mpp north fold 
    506       ! 
    507       llmpiNFold =          jpni  > 1 .AND. l_NFold   ! is the North fold done with an MPI communication? 
    508       l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold   ! is this process doing North fold? 
    509       ! 
    510       IF( llmpiNFold ) THEN 
    511          CALL mpp_ini_north 
    512          IF (lwp) THEN 
    513             WRITE(numout,*) 
    514             WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1' 
    515          ENDIF 
    516          IF (llwrtlay) THEN      ! additional prints in layout.dat 
    517             WRITE(inum,*) 
    518             WRITE(inum,*) 
    519             WRITE(inum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 
    520             WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 
    521             DO jp = 1, ndim_rank_north, 5 
    522                WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 
    523             END DO 
    524          ENDIF 
    525          IF ( l_IdoNFold .AND. ln_nnogather ) THEN 
    526             CALL init_nfdcom     ! northfold neighbour lists 
    527             IF (llwrtlay) THEN 
    528                WRITE(inum,*) 
    529                WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 
    530                WRITE(inum,*) '   nsndto  : ', nsndto 
    531                WRITE(inum,*) '   isendto : ', isendto(1:nsndto) 
    532             ENDIF 
    533          ENDIF 
    534       ENDIF 
    535506      ! 
    536507      CALL mpp_ini_nc(nn_hls)    ! Initialize communicator for neighbourhood collective communications 
     
    539510         mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) 
    540511      END DO 
    541       ! 
    542       IF( jpnij > 1) CALL init_excl_landpt      ! exclude exchanges which contain only land points 
    543       ! 
    544       ! Save processor layout changes in ascii file 
     512      !                          ! Exclude exchanges which contain only land points 
     513      ! 
     514      IF( jpnij > 1 ) CALL init_excl_landpt 
     515      ! 
     516      !                          ! Prepare mpp north fold 
     517      ! 
     518      llmpiNFold =          jpni  > 1 .AND. l_NFold           ! is the North fold done with an MPI communication? 
     519      l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold           ! is this process doing North fold? 
     520      ! 
     521      IF( llmpiNFold )   CALL init_nfdcom( llwrtlay, inum )   ! init northfold communication, must be done after init_excl_landpt 
     522      ! 
     523      !                          !  Save processor layout changes in ascii file 
     524      ! 
    545525      DO jh = 1, n_hlsmax    ! different halo size 
    546526         DO ji = 1, 8 
     
    732712      isziref = jpiglo*jpjglo+1   ! define a value that is larger than the largest possible 
    733713      iszjref = jpiglo*jpjglo+1 
     714      ! 
     715      ! WARNING, see also init_excl_landpt: minimum subdomain size defined here according to nn_hls (and not n_hlsmax) 
     716      ! --> If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax 
    734717      ! 
    735718      iszimin = 3*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 
     
    11651148      INTEGER ::   iiwe, iiea, iist, iisz  
    11661149      INTEGER ::   ijso, ijno, ijst, ijsz  
    1167       LOGICAL ::   llsave 
    11681150      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zmsk 
    11691151      LOGICAL , DIMENSION(Ni_0,Nj_0,1)      ::   lloce 
     
    11741156      ! 
    11751157      ! Here we look only at communications excluding the NP folding. 
    1176       ! As lbcnfd not validated if halo size /= nn_hls, we switch if off temporary... 
    1177       llsave = l_IdoNFold 
     1158      !   --> we switch off lbcnfd at this stage (init_nfdcom called after init_excl_landpt)... 
    11781159      l_IdoNFold = .FALSE. 
    11791160      ! 
    1180       DO jh = 1, n_hlsmax    ! different halo size 
     1161      ! WARNING, see also bestpartition: minimum subdomain size defined in bestpartition according to nn_hls. 
     1162      ! If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax in bestpartition 
     1163      ! 
     1164      DO jh = 1, MIN(nn_hls, n_hlsmax)   ! different halo size 
    11811165         ! 
    11821166         ipi = Ni_0 + 2*jh   ! local domain size 
     
    11861170         zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp)   ! define inner domain -> need REAL to use lbclnk 
    11871171         CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh)                 ! fill halos 
     1172         ! Beware, coastal F points can be used in the code -> we may need communications for these points F points even if tmask = 0 
     1173         ! -> the mask we must use here is equal to 1 as soon as one of the 4 neighbours is oce (sum of the mask, not multiplication) 
     1174         zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = zmsk(jh+1:jh+Ni_0,jh+1  :jh+Nj_0  ) + zmsk(jh+1+1:jh+Ni_0+1,jh+1  :jh+Nj_0  )   & 
     1175            &                            + zmsk(jh+1:jh+Ni_0,jh+1+1:jh+Nj_0+1) + zmsk(jh+1+1:jh+Ni_0+1,jh+1+1:jh+Nj_0+1) 
     1176         CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh)                 ! fill halos again! 
    11881177         !         
    1189          iiwe = jh   ;   iiea = Ni_0   ! bottom-left corfer - 1 of the sent data 
     1178         iiwe = jh   ;   iiea = Ni_0   ! bottom-left corner - 1 of the sent data 
    11901179         ijso = jh   ;   ijno = Nj_0 
    11911180         IF( nn_comm == 1 ) THEN  
    11921181            iist =  0   ;   iisz = ipi 
    1193             ijst =  0   ;   ijsz = ipj 
     1182            ijst = jh   ;   ijsz = Nj_0 
    11941183         ELSE 
    11951184            iist = jh   ;   iisz = Ni_0 
     
    12071196         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijno+1:ijno+jh  ) )) == 0 )   mpiSnei(jh,jpne) = -1 
    12081197         ! 
    1209          iiwe = iiwe-jh   ;   iiea = iiea+jh   ! bottom-left corfer - 1 of the received data 
     1198         iiwe = iiwe-jh   ;   iiea = iiea+jh   ! bottom-left corner - 1 of the received data 
    12101199         ijso = ijso-jh   ;   ijno = ijno+jh 
    12111200         ! do not send if we send only land points 
     
    12331222         ! 
    12341223      END DO 
    1235       l_IdoNFold = llsave 
    12361224 
    12371225   END SUBROUTINE init_excl_landpt 
     
    12781266 
    12791267 
    1280    SUBROUTINE init_nfdcom 
     1268   SUBROUTINE init_nfdcom( ldwrtlay, knum ) 
    12811269      !!---------------------------------------------------------------------- 
    12821270      !!                     ***  ROUTINE  init_nfdcom  *** 
     
    12881276      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE) 
    12891277      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 
    1290       !!---------------------------------------------------------------------- 
    1291       INTEGER  ::   sxM, dxM, sxT, dxT, jn 
    1292       !!---------------------------------------------------------------------- 
    1293       ! 
    1294       !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 
    1295       sxM = jpiglo - nimpp - jpi + 1 
    1296       !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 
    1297       dxM = jpiglo - nimpp + 2 
    1298       ! 
    1299       ! loop over the other north-fold processes to find the processes 
    1300       ! managing the points belonging to the sxT-dxT range 
    1301       ! 
    1302       nsndto = 0 
    1303       DO jn = 1, jpni 
     1278      !!    3.0  ! 2021-09 complete rewrite using informations from gather north fold 
     1279      !!---------------------------------------------------------------------- 
     1280      LOGICAL, INTENT(in   ) ::   ldwrtlay   ! true if additional prints in layout.dat 
     1281      INTEGER, INTENT(in   ) ::   knum       ! layout.dat unit 
     1282      ! 
     1283      REAL(wp), DIMENSION(jpi,jpj,2,4) ::   zinfo 
     1284      INTEGER , DIMENSION(10) ::   irknei ! too many elements but safe... 
     1285      INTEGER                 ::   ji, jj, jg, jn   ! dummy loop indices 
     1286      LOGICAL                 ::   lnew 
     1287      !!---------------------------------------------------------------------- 
     1288      ! 
     1289      IF (lwp) THEN 
     1290         WRITE(numout,*) 
     1291         WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1' 
     1292      ENDIF 
     1293      ! 
     1294      CALL mpp_ini_northgather   ! we need to init the nfd with gathering in all cases as it is used to define the no-gather case 
     1295      ! 
     1296      IF(ldwrtlay) THEN      ! additional prints in layout.dat 
     1297         WRITE(knum,*) 
     1298         WRITE(knum,*) 
     1299         WRITE(knum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 
     1300         WRITE(knum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 
     1301         DO jn = 1, ndim_rank_north, 5 
     1302            WRITE(knum,*) nrank_north( jn:MINVAL( (/jn+4,ndim_rank_north/) ) ) 
     1303         END DO 
     1304      ENDIF 
     1305       
     1306      nfd_nbnei = 0   ! defaul def (useless?) 
     1307      IF( ln_nnogather ) THEN 
    13041308         ! 
    1305          sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process 
    1306          dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process 
     1309         ! Use the "gather nfd" to know how to do the nfd: for ji point, which process send data from which of its ji-index? 
     1310         ! Note that nfd is perfectly symetric: I receive data from X <=> I send data to X  (-> no deadlock) 
    13071311         ! 
    1308          IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN 
    1309             nsndto          = nsndto + 1 
    1310             isendto(nsndto) = jn 
    1311          ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN 
    1312             nsndto          = nsndto + 1 
    1313             isendto(nsndto) = jn 
    1314          ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN 
    1315             nsndto          = nsndto + 1 
    1316             isendto(nsndto) = jn 
    1317          ENDIF 
     1312         zinfo(:,:,:,:) = HUGE(0._wp)   ! default def to make sure we don't use the halos 
     1313         DO jg = 1, 4   ! grid type: T, U, V, F 
     1314            DO jj = nn_hls+1, jpj-nn_hls                ! inner domain (warning do_loop_substitute not yet defined) 
     1315               DO ji = nn_hls+1, jpi-nn_hls             ! inner domain (warning do_loop_substitute not yet defined) 
     1316                  zinfo(ji,jj,1,jg) = REAL(narea, wp)   ! mpi_rank + 1 (as default lbc_lnk fill is 0 
     1317                  zinfo(ji,jj,2,jg) = REAL(ji, wp)      ! ji of this proc 
     1318               END DO 
     1319            END DO 
     1320         END DO 
    13181321         ! 
    1319       END DO 
     1322         ln_nnogather = .FALSE.   ! force "classical" North pole folding to fill all halos -> should be no more HUGE values... 
     1323         CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp )   ! Do 4 calls instead of 1 to save memory as the nogather version 
     1324         CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp )   ! creates buffer arrays with jpiglo as the first dimension 
     1325         CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp )   !  
     1326         CALL lbc_lnk( 'mppini', zinfo(:,:,:,4), 'F', 1._wp )   !  
     1327         ln_nnogather = .TRUE. 
     1328          
     1329         IF( l_IdoNFold ) THEN   ! only the procs involed in the NFD must take care of this 
     1330             
     1331            ALLOCATE( nfd_rksnd(jpi,4), nfd_jisnd(jpi,4) )          ! neighbour rand and remote ji-index for each grid (T, U, V, F) 
     1332            nfd_rksnd(:,:) = NINT( zinfo(:, jpj, 1, :) ) - 1        ! neighbour MPI rank 
     1333            nfd_jisnd(:,:) = NINT( zinfo(:, jpj, 2, :) ) - nn_hls   ! neighbour ji index (shifted as we don't send the halos) 
     1334            WHERE( nfd_rksnd == -1 )   nfd_jisnd = 1                ! use ji=1 if no neighbour, see mpp_nfd_generic.h90 
     1335             
     1336            nfd_nbnei = 1                ! Number of neighbour sending data for the nfd. We have at least 1 neighbour! 
     1337            irknei(1) = nfd_rksnd(1,1)   ! which is the 1st one (I can be neighbour of myself, exclude land-proc are also ok) 
     1338            DO jg = 1, 4 
     1339               DO ji = 1, jpi     ! we must be able to fill the full line including halos 
     1340                  lnew = .TRUE.   ! new neighbour? 
     1341                  DO jn = 1, nfd_nbnei 
     1342                     IF( irknei(jn) == nfd_rksnd(ji,jg) )   lnew = .FALSE.   ! already found 
     1343                  END DO 
     1344                  IF( lnew ) THEN 
     1345                     jn = nfd_nbnei + 1 
     1346                     nfd_nbnei = jn 
     1347                     irknei(jn) = nfd_rksnd(ji,jg) 
     1348                  ENDIF 
     1349               END DO 
     1350            END DO 
     1351             
     1352            ALLOCATE( nfd_rknei(nfd_nbnei) ) 
     1353            nfd_rknei(:) = irknei(1:nfd_nbnei) 
     1354            ! re-number nfd_rksnd according to the indexes of nfd_rknei 
     1355            DO jn = 1, nfd_nbnei 
     1356               WHERE( nfd_rksnd == nfd_rknei(jn) )   nfd_rksnd = jn 
     1357            END DO 
     1358             
     1359            IF( ldwrtlay ) THEN 
     1360               WRITE(knum,*) 
     1361               WRITE(knum,*) 'north fold exchanges with explicit point-to-point messaging :' 
     1362               WRITE(knum,*) '   number of neighbours for the NF: nfd_nbnei : ', nfd_nbnei 
     1363               IF( nfd_nbnei > 0 )   WRITE(knum,*) '   neighbours MPI ranks                       : ', nfd_rknei 
     1364            ENDIF 
     1365             
     1366         ENDIF   ! l_IdoNFold 
     1367         ! 
     1368      ENDIF   ! ln_nnogather 
    13201369      ! 
    13211370   END SUBROUTINE init_nfdcom 
     
    13421391   END SUBROUTINE init_doloop 
    13431392 
     1393    
     1394   SUBROUTINE init_locglo 
     1395      !!---------------------------------------------------------------------- 
     1396      !!                     ***  ROUTINE init_locglo  *** 
     1397      !! 
     1398      !! ** Purpose :   initialization of global domain <--> local domain indices 
     1399      !! 
     1400      !! ** Method  : 
     1401      !! 
     1402      !! ** Action  : - mig , mjg : local  domain indices ==> global domain, including halos, indices 
     1403      !!              - mig0, mjg0: local  domain indices ==> global domain, excluding halos, indices 
     1404      !!              - mi0 , mi1 : global domain indices ==> local  domain indices 
     1405      !!              - mj0 , mj1   (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 
     1406      !!---------------------------------------------------------------------- 
     1407      INTEGER ::   ji, jj   ! dummy loop argument 
     1408      !!---------------------------------------------------------------------- 
     1409      ! 
     1410      ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj) ) 
     1411      ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo) ) 
     1412      ! 
     1413      DO ji = 1, jpi                 ! local domain indices ==> global domain indices, including halos 
     1414        mig(ji) = ji + nimpp - 1 
     1415      END DO 
     1416      DO jj = 1, jpj 
     1417        mjg(jj) = jj + njmpp - 1 
     1418      END DO 
     1419      !                              ! local domain indices ==> global domain indices, excluding halos 
     1420      ! 
     1421      mig0(:) = mig(:) - nn_hls 
     1422      mjg0(:) = mjg(:) - nn_hls 
     1423      !                              ! global domain, including halos, indices ==> local domain indices 
     1424      !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 
     1425      !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 
     1426      DO ji = 1, jpiglo 
     1427        mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) 
     1428        mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi   ) ) 
     1429      END DO 
     1430      DO jj = 1, jpjglo 
     1431        mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) 
     1432        mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj   ) ) 
     1433      END DO 
     1434      ! 
     1435   END SUBROUTINE init_locglo 
     1436    
    13441437   !!====================================================================== 
    13451438END MODULE mppini 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcmod.F90

    r15127 r15349  
    380380      REAL(wp) ::     zthscl        ! wd  tanh scale 
    381381      REAL(wp), DIMENSION(jpi,jpj) ::  zwdht, zwght  ! wd dep over wd limit, wgt 
     382      REAL(wp), DIMENSION(jpi,jpj) ::  z2d           ! temporary array used for iom_put 
    382383 
    383384      !!--------------------------------------------------------------------- 
     
    567568      !                                                ! ---------------------------------------- ! 
    568569      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    569          CALL iom_put( "empmr"  , emp   - rnf )                ! upward water flux 
    570          CALL iom_put( "empbmr" , emp_b - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
     570         IF( iom_use("empmr") ) THEN 
     571            DO_2D( 0, 0, 0, 0 ) 
     572               z2d(ji,jj) =  emp(ji,jj) - rnf(ji,jj) 
     573            END_2D 
     574            CALL iom_put( "empmr"  , z2d      )                ! upward water flux 
     575         ENDIF 
     576         IF( iom_use("empbmr") ) THEN 
     577            DO_2D( 0, 0, 0, 0 ) 
     578               z2d(ji,jj) =  emp_b(ji,jj) - rnf(ji,jj) 
     579            END_2D 
     580            CALL iom_put( "empbmr" , z2d      )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
     581         ENDIF 
    571582         CALL iom_put( "saltflx", sfx         )                ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) 
    572583         CALL iom_put( "fmmflx" , fmmflx      )                ! Freezing-melting water flux 
    573          CALL iom_put( "qt"     , qns + qsr   )                ! total heat flux 
     584         IF( iom_use("qt") ) THEN 
     585            DO_2D( 0, 0, 0, 0 ) 
     586               z2d(ji,jj) =  qns(ji,jj) + qsr(ji,jj) 
     587            END_2D 
     588            CALL iom_put( "qt"  , z2d         )                ! total heat flux 
     589         ENDIF 
    574590         CALL iom_put( "qns"    , qns         )                ! solar heat flux 
    575          CALL iom_put( "qsr"    ,       qsr   )                ! solar heat flux 
     591         CALL iom_put( "qsr"    , qsr         )                ! solar heat flux 
    576592         IF( nn_ice > 0 .OR. ll_opa )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction 
    577593         CALL iom_put( "taum"   , taum        )                ! wind stress module 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcrnf.F90

    r15127 r15349  
    519519      ! 
    520520      cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname ) 
    521       IF( .NOT. sn_cnf%ln_clim ) THEN   ;   WRITE(cl_rnfile, '(a,"_y",i4)' ) TRIM( cl_rnfile ), nyear    ! add year 
    522          IF( sn_cnf%clftyp == 'monthly' )   WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth   ! add month 
     521      IF( .NOT. sn_cnf%ln_clim ) THEN   ;   WRITE(cl_rnfile, '(a,"_y",i4.4)' ) TRIM( cl_rnfile ), nyear    ! add year 
     522         IF( sn_cnf%clftyp == 'monthly' )   WRITE(cl_rnfile, '(a,"m" ,i2.2)' ) TRIM( cl_rnfile ), nmonth   ! add month 
    523523      ENDIF 
    524524      ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcssm.F90

    r15127 r15349  
    6565      zts(:,:,jp_sal) = ts(:,:,1,jp_sal,Kmm) 
    6666      ! 
    67       IF( nn_fsbc == 1 ) THEN                             !   Instantaneous surface fields        ! 
     67         !                                                ! ---------------------------------------- ! 
     68      IF( nn_fsbc == 1 ) THEN                             !      Instantaneous surface fields        ! 
    6869         !                                                ! ---------------------------------------- ! 
    6970         ssu_m(:,:) = uu(:,:,1,Kbb) 
     
    9293            ssu_m(:,:) = zcoef * uu(:,:,1,Kbb) 
    9394            ssv_m(:,:) = zcoef * vv(:,:,1,Kbb) 
    94             IF( l_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
     95            IF( l_useCT   )  THEN   ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    9596            ELSE                    ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem) 
    9697            ENDIF 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcwave.F90

    r15127 r15349  
    516516            ! 
    517517            ! 3. Wave number (only needed for Qiao parametrisation, ln_zdfswm=T) 
    518             IF( ln_zdfswm .AND. .NOT. cpl_wnum ) THEN 
     518            IF( .NOT. cpl_wnum ) THEN 
    519519               ALLOCATE( sf_wn(1), STAT=ierror )           !* allocate and fill sf_wave with sn_wnum 
    520520               IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/eosbn2.F90

    r15127 r15349  
    10811081         ! 
    10821082         zt  = ctmp   (ji,jj) * z1_T0 
    1083          zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
     1083         zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 ) 
    10841084         ztm = tmask(ji,jj,1) 
    10851085         ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_mus.F90

    r15127 r15349  
    197197         zwx(:,:, 1 ) = 0._wp                   ! surface & bottom boundary conditions 
    198198         zwx(:,:,jpk) = 0._wp 
    199          DO_3D( 1, 1, 1, 1, 2, jpkm1 )                ! interior values 
     199         DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! interior values 
    200200            zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    201201         END_3D 
    202202         !                                !-- Slopes of tracer 
    203203         zslpx(:,:,1) = 0._wp                   ! surface values 
    204          DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
     204         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    205205            zslpx(ji,jj,jk) =                        ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
    206206               &            * (  0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
    207207         END_3D 
    208          DO_3D( 1, 1, 1, 1, 2, jpkm1 )    !-- Slopes limitation 
     208         DO_3D( 0, 0, 0, 0, 2, jpkm1 )    !-- Slopes limitation 
    209209            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    210210               &                                                     2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     
    221221         IF( ln_linssh ) THEN                   ! top values, linear free surface only 
    222222            IF( ln_isfcav ) THEN                      ! ice-shelf cavities (top of the ocean) 
    223                DO_2D( 1, 1, 1, 1 ) 
     223               DO_2D( 0, 0, 0, 0 ) 
    224224                  zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) 
    225225               END_2D 
    226226            ELSE                                      ! no cavities: only at the ocean surface 
    227                DO_2D( 1, 1, 1, 1 ) 
     227               DO_2D( 0, 0, 0, 0 ) 
    228228                  zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 
    229229               END_2D 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/USR/usrdef_sbc.F90

    r14448 r15349  
    110110      ztrp= - 40.e0        ! retroaction term on heat fluxes (W/m2/K) 
    111111      zconv = 3.16e-5      ! convertion factor: 1 m/yr => 3.16e-5 mm/s 
    112       DO_2D( 1, 1, 1, 1 ) 
     112      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )   ! emp and rnf used in sshwzv over the whole domain 
    113113         ! domain from 15 deg to 50 deg between 27 and 28  degC at 15N, -3 
    114114         ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period : 
     
    136136 
    137137      ! freshwater (mass flux) and update of qns with heat content of emp 
    138       emp (:,:) = emp(:,:) - zsumemp * tmask(:,:,1)        ! freshwater flux (=0 in domain average) 
    139       sfx (:,:) = 0.0_wp                                   ! no salt flux 
    140       qns (:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp   ! evap and precip are at SST 
     138      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )   ! emp used in sshwzv over the whole domain 
     139         emp (ji,jj) = emp(ji,jj) - zsumemp * tmask(ji,jj,1)          ! freshwater flux (=0 in domain average) 
     140         sfx (ji,jj) = 0.0_wp                                         ! no salt flux 
     141         qns (ji,jj) = qns(ji,jj) - emp(ji,jj) * sst_m(ji,jj) * rcp   ! evap and precip are at SST 
     142      END_2D 
    141143 
    142144 
     
    181183         wndm(ji,jj) = SQRT( zmod * zcoef ) 
    182184      END_2D 
    183       CALL lbc_lnk( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 
    184185 
    185186      ! ---------------------------------- ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfevd.F90

    r15127 r15349  
    128128         zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) - zavt_evd(ji,jj,jk)   ! change in avt due to evd 
    129129      END_3D 
     130      ! 
     131      IF( l_trdtra ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_evd, zavt_evd ) 
     132      ! 
    130133      IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
    131134         CALL iom_put( "avt_evd", zavt_evd )              ! output this change 
    132135         DEALLOCATE( zavt_evd ) 
    133136      ENDIF 
    134       IF( l_trdtra ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_evd, zavt_evd ) 
    135137      ! 
    136138   END SUBROUTINE zdf_evd 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfgls.F90

    r15127 r15349  
    12461246            ! 
    12471247            IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN        ! all required arrays exist 
    1248                CALL iom_get( numror, jpdom_auto, 'en'    , en     ) 
     1248               CALL iom_get( numror, jpdom_auto, 'en'    , en   , kfill = jpfillcopy  )   ! we devide by en -> must be != 0. 
    12491249               CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k  ) 
    12501250               CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k  ) 
    1251                CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n ) 
     1251               CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, kfill = jpfillcopy )   ! we devide by hmxl_n -> must be != 0. 
    12521252            ELSE 
    12531253               IF(lwp) WRITE(numout,*) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfmxl.F90

    r15127 r15349  
    2626   PRIVATE 
    2727 
    28    PUBLIC   zdf_mxl, zdf_mxl_turb   ! called by zdfphy.F90 
     28   PUBLIC   zdf_mxl, zdf_mxl_turb, zdf_mxl_alloc   ! called by zdfphy.F90 
    2929 
    3030   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP) 
     
    8686            IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth' 
    8787            IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    88             !                             ! allocate zdfmxl arrays 
    89             IF( zdf_mxl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' ) 
    9088         ENDIF 
    9189      ENDIF 
     
    111109      ! 
    112110      IF( .NOT.l_offline .AND. iom_use("mldr10_1") ) THEN 
    113          IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
    114          ELSE                  ;  CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
    115          END IF 
     111         IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN         ! Do only on the last tile 
     112            IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     113            ELSE                  ;  CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     114            END IF 
     115         ENDIF 
    116116      ENDIF 
    117117      ! 
     
    144144      ! w-level of the turbocline and mixing layer (iom_use) 
    145145      imld(:,:) = mbkt(A2D(nn_hls)) + 1                ! Initialization to the number of w ocean point 
    146       DO_3DS( nn_hls, nn_hls, nn_hls, nn_hls, jpkm1, nlb10, -1 )   ! from the bottom to nlb10 
     146      DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )   ! from the bottom to nlb10 
    147147         IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline 
    148148      END_3D 
    149149      ! depth of the mixing layer 
    150       DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) 
     150      DO_2D_OVR( 1, 1, 1, 1 ) 
    151151         iik = imld(ji,jj) 
    152152         hmld (ji,jj) = gdepw(ji,jj,iik  ,Kmm) * ssmask(ji,jj)    ! Turbocline depth 
     
    154154      ! 
    155155      IF( .NOT.l_offline .AND. iom_use("mldkz5") ) THEN 
    156          IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
    157          ELSE                  ;  CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
    158          END IF 
     156         IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN         ! Do only on the last tile 
     157            IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     158            ELSE                  ;  CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     159            END IF 
     160         ENDIF 
    159161      ENDIF 
    160162      ! 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfphy.F90

    r15127 r15349  
    146146         wi    (:,:,:) = 0._wp 
    147147      ENDIF 
     148      !                                  ! Initialise zdf_mxl arrays (only hmld as not set everywhere when nn_hls > 1) 
     149      IF( zdf_mxl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' ) 
     150      hmld(:,:) = 0._wp 
    148151      !                          !==  Background eddy viscosity and diffusivity  ==! 
    149152      IF( nn_avb == 0 ) THEN             ! Define avmb, avtb from namelist parameter 
     
    378381      IF( iom_use('avt_k') .OR. iom_use('avm_k') .OR. iom_use('eshear_k') .OR. iom_use('estrat_k') ) THEN 
    379382         IF( l_zdfsh2 ) THEN 
    380             DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    381                zsh2(ji,jj,1  ) = 0._wp 
    382                zsh2(ji,jj,jpk) = 0._wp 
    383             END_2D 
    384383            CALL iom_put( 'avt_k'   ,   avt_k       * wmask ) 
    385384            CALL iom_put( 'avm_k'   ,   avm_k       * wmask ) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfric.F90

    r15127 r15349  
    157157      ! 
    158158      !                       !==  avm and avt = F(Richardson number)  ==! 
    159       DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 2, jpkm1 )       ! coefficient = F(richardson number) (avm-weighted Ri) 
     159      DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )       ! coefficient = F(richardson number) (avm-weighted Ri) 
    160160         zcfRi = 1._wp / (  1._wp + rn_alp * MAX(  0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) )  ) 
    161161         zav   = rn_avmri * zcfRi**nn_ric 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfsh2.F90

    r15127 r15349  
    9696         END_2D 
    9797      END DO 
     98      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! set p_sh2 to 0 at the surface and bottom for output purpose 
     99         p_sh2(ji,jj,1)   = 0._wp 
     100         p_sh2(ji,jj,jpk) = 0._wp 
     101      END_2D 
    98102      ! 
    99103   END SUBROUTINE zdf_sh2 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/lib_fortran.F90

    r15127 r15349  
    2626   PRIVATE 
    2727 
    28    PUBLIC   glob_sum      ! used in many places (masked with tmask_i) 
    29    PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos) 
     28   PUBLIC   glob_sum      ! used in many places (masked with tmask_i = ssmask * tmask_h) 
     29   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, excluding all duplicated points halos+periodicity) 
    3030   PUBLIC   local_sum     ! used in trcrad, local operation before glob_sum_delay 
    3131   PUBLIC   sum3x3        ! used in trcrad, do a sum over 3x3 boxes 
     
    331331      INTEGER     ::   ji , jj , jk     ! dummy loop indices 
    332332      INTEGER     ::   ipi, ipj, ipk    ! dimensions 
     333      INTEGER     ::   iis, iie, ijs, ije   ! loop start and end 
    333334      !!----------------------------------------------------------------------- 
    334335      ! 
     
    337338      ipk = SIZE(ptab,3)   ! 3rd dimension 
    338339      ! 
     340      IF( ipi == jpi .AND. ipj == jpj ) THEN   ! do 2D loop only over the inner domain (-> avoid to use undefined values) 
     341         iis = Nis0   ;   iie = Nie0 
     342         ijs = Njs0   ;   ije = Nje0 
     343      ELSE                                     ! I think we are never in this case... 
     344         iis = 1   ;   iie = jpi 
     345         ijs = 1   ;   ije = jpj 
     346      ENDIF 
     347      ! 
    339348      ALLOCATE( ctmp(ipk) ) 
    340349      ! 
    341350      DO jk = 1, ipk 
    342351         ctmp(jk) = CMPLX( 0.e0, 0.e0, dp )   ! warning ctmp is cumulated 
    343          DO jj = 1, ipj 
    344             DO ji = 1, ipi 
     352         DO jj = ijs, ije 
     353            DO ji = iis, iie 
    345354               ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj) 
    346355               CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jk) ) 
     
    366375      INTEGER     ::   ji , jj , jk , jl     ! dummy loop indices 
    367376      INTEGER     ::   ipi, ipj, ipk, ipl    ! dimensions 
     377      INTEGER     ::   iis, iie, ijs, ije    ! loop start and end 
    368378      !!----------------------------------------------------------------------- 
    369379      ! 
     
    373383      ipl = SIZE(ptab,4)   ! 4th dimension 
    374384      ! 
     385      IF( ipi == jpi .AND. ipj == jpj ) THEN   ! do 2D loop only over the inner domain (-> avoid to use undefined values) 
     386         iis = Nis0   ;   iie = Nie0 
     387         ijs = Njs0   ;   ije = Nje0 
     388      ELSE                                     ! I think we are never in this case... 
     389         iis = 1   ;   iie = jpi 
     390         ijs = 1   ;   ije = jpj 
     391      ENDIF 
     392      ! 
    375393      ALLOCATE( ctmp(ipl) ) 
    376394      ! 
     
    378396         ctmp(jl) = CMPLX( 0.e0, 0.e0, dp )   ! warning ctmp is cumulated 
    379397         DO jk = 1, ipk 
    380             DO jj = 1, ipj 
    381                DO ji = 1, ipi 
     398            DO jj = ijs, ije 
     399               DO ji = iis, iie 
    382400                  ztmp =  ptab(ji,jj,jk,jl) * tmask_i(ji,jj) 
    383401                  CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jl) ) 
     
    404422      INTEGER     ::   ji , jj , jk     ! dummy loop indices 
    405423      INTEGER     ::   ipi, ipj, ipk    ! dimensions 
     424      INTEGER     ::   iis, iie, ijs, ije   ! loop start and end 
    406425      !!----------------------------------------------------------------------- 
    407426      ! 
     
    410429      ipk = SIZE(ptab,3)   ! 3rd dimension 
    411430      ! 
     431      IF( ipi == jpi .AND. ipj == jpj ) THEN   ! do 2D loop only over the inner domain (-> avoid to use undefined values) 
     432         iis = Nis0   ;   iie = Nie0 
     433         ijs = Njs0   ;   ije = Nje0 
     434      ELSE                                     ! I think we are never in this case... 
     435         iis = 1   ;   iie = jpi 
     436         ijs = 1   ;   ije = jpj 
     437      ENDIF 
     438      ! 
    412439      ALLOCATE( ctmp(ipk) ) 
    413440      ! 
    414441      DO jk = 1, ipk 
    415442         ctmp(jk) = CMPLX( 0.e0, 0.e0, dp )   ! warning ctmp is cumulated 
    416          DO jj = 1, ipj 
    417             DO ji = 1, ipi 
     443         DO jj = ijs, ije 
     444            DO ji = iis, iie 
    418445               ztmp =  ptab(ji,jj,jk) * tmask_h(ji,jj) 
    419446               CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jk) ) 
     
    439466      INTEGER     ::   ji , jj , jk , jl     ! dummy loop indices 
    440467      INTEGER     ::   ipi, ipj, ipk, ipl    ! dimensions 
     468      INTEGER     ::   iis, iie, ijs, ije    ! loop start and end 
    441469      !!----------------------------------------------------------------------- 
    442470      ! 
     
    446474      ipl = SIZE(ptab,4)   ! 4th dimension 
    447475      ! 
     476      IF( ipi == jpi .AND. ipj == jpj ) THEN   ! do 2D loop only over the inner domain (-> avoid to use undefined values) 
     477         iis = Nis0   ;   iie = Nie0 
     478         ijs = Njs0   ;   ije = Nje0 
     479      ELSE                                     ! I think we are never in this case... 
     480         iis = 1   ;   iie = jpi 
     481         ijs = 1   ;   ije = jpj 
     482      ENDIF 
     483      ! 
    448484      ALLOCATE( ctmp(ipl) ) 
    449485      ! 
     
    451487         ctmp(jl) = CMPLX( 0.e0, 0.e0, dp )   ! warning ctmp is cumulated 
    452488         DO jk = 1, ipk 
    453             DO jj = 1, ipj 
    454                DO ji = 1, ipi 
     489            DO jj = ijs, ije 
     490               DO ji = iis, iie 
    455491                  ztmp =  ptab(ji,jj,jk,jl) * tmask_h(ji,jj) 
    456492                  CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jl) ) 
  • NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/lib_fortran_generic.h90

    r13226 r15349  
    3838      !!----------------------------------------------------------------------- 
    3939