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

Changeset 14062


Ignore:
Timestamp:
2020-12-03T17:39:30+01:00 (3 years ago)
Author:
ayoung
Message:

Updating to trunk at 14060 and resolving conflicts with ticket #2480. Ticket #2506.

Location:
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
Files:
21 deleted
99 edited
7 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg

    r14037 r14062  
    299299!----------------------------------------------------------------------- 
    300300   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    301       nn_een_e3f = 0          ! =0   e3f = mean masked e3t divided by 4 
    302301/ 
    303302!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg

    r14037 r14062  
    300300!----------------------------------------------------------------------- 
    301301   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    302       nn_een_e3f = 0          ! =0   e3f = mean masked e3t divided by 4 
    303302/ 
    304303!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AMM12/EXPREF/namelist_cfg

    r14037 r14062  
    291291!----------------------------------------------------------------------- 
    292292   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    293       nn_een_e3f = 1             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
     293   nn_e3f_typ = 1          !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    294294/ 
    295295!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg

    r14037 r14062  
    334334!----------------------------------------------------------------------- 
    335335   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    336       nn_een_e3f = 0          ! =0   e3f = mean masked e3t divided by 4 
    337336/ 
    338337!----------------------------------------------------------------------- 
    … …  
    389388      !                       !                 = 3 as =2 with distinct dissipative an mixing length scale 
    390389      nn_etau     =   1       !  penetration of tke below the mixed layer (ML) due to NIWs 
    391                                !        = 0 none ; = 1 add a tke source below the ML 
    392                                !        = 2 add a tke source just at the base of the ML 
    393                                !        = 3 as = 1 applied on HF part of the stress           (ln_cpl=T) 
     390      !                       !        = 0 none ; = 1 add a tke source below the ML 
     391      !                       !        = 2 add a tke source just at the base of the ML 
     392      !                       !        = 3 as = 1 applied on HF part of the stress           (ln_cpl=T) 
    394393      ln_mxhsw    = .false.   !  surface mixing length scale = F(wave height) 
    395394/ 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/axis_def_nemo.xml

    r12377 r14062  
    1414      <axis id="depthv"  long_name="Vertical V levels" unit="m" positive="down" /> 
    1515      <axis id="depthw"  long_name="Vertical W levels" unit="m" positive="down" /> 
     16      <axis id="depthf"  long_name="Vertical F levels" unit="m" positive="down" /> 
    1617      <axis id="nfloat"  long_name="Float number"      unit="-"                 /> 
    1718      <axis id="icbcla"  long_name="Iceberg class"      unit="1"               /> 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/domain_def_nemo.xml

    r12276 r14062  
    181181     <domain id="EqW" domain_ref="grid_W" > <zoom_domain id="EqW"/> </domain> 
    182182 
     183     <!--   F grid   --> 
     184     <domain id="grid_F" long_name="grid F"/> 
     185      
    183186              <!--   zonal mean grid   --> 
    184187     <domain_group id="gznl"> 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/field_def_nemo-oce.xml

    r14037 r14062  
    171171        <field id="tosmint_pot"  long_name="vertical integral of potential temperature times density"   standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature"  unit="(kg m2) degree_C" /> 
    172172 
    173  
     173        <field id="ht"           long_name="water column height at T point"                     standard_name="water_column_height_T"                      unit="m" /> 
    174174        <field id="ssh"          long_name="sea surface height"                                 standard_name="sea_surface_height_above_geoid"             unit="m" /> 
    175175        <field id="ssh2"         long_name="square of sea surface height"                       standard_name="square_of_sea_surface_height_above_geoid"   unit="m2" > ssh * ssh </field > 
    … …  
    190190 
    191191        <!-- Energy - horizontal divergence --> 
     192        <field id="sKE"          long_name="surface kinetic energy"  standard_name="specific_kinetic_energy_of_sea_water"   unit="m2/s2"  grid_ref="grid_T_2D" /> 
    192193        <field id="hdiv"         long_name="horizontal divergence"                                                          unit="s-1"    grid_ref="grid_T_3D" /> 
    193194 
    … …  
    270271 
    271272      <field_group id="OSMOSIS_T" grid_ref="grid_T_2D"> 
     273        <field id="hml"                 long_name="mixed layr depth"                         unit="m"       /> 
     274        <field id="hbl"                 long_name="boundary layer depth"                     unit="m"       /> 
     275        <field id="dh"                  long_name="Pycnocline thickness"                     unit=" m"      /> 
     276        <field id="ibld"                long_name="index of boundary layer depth"            unit="#"       /> 
     277        <field id="imld"                long_name="index of mixed layer depth"            unit="#"       /> 
     278        <field id="zhbl"                long_name="boundary layer depth -grid"                     unit="m"       /> 
     279        <field id="zhml"                long_name="mixed layer depth - grid"                        unit="m"       /> 
     280        <field id="zdh"                 long_name="Pycnocline  depth - grid"                 unit=" m"      /> 
     281        <field id="zustke"              long_name="magnitude of stokes drift  at T-points"   unit="m/s"     /> 
     282        <field id="us_x"        long_name="i component of active Stokes drift"                      unit="m/s"     /> 
     283        <field id="us_y"        long_name="j component of active Stokes drift"                      unit="m/s"     /> 
     284        <field id="dstokes"             long_name="stokes drift  depth scale"                unit="m"       /> 
    272285        <field id="zwth0"               long_name="surface non-local temperature flux"       unit="deg m/s" /> 
    273286        <field id="zws0"                long_name="surface non-local salinity flux"          unit="psu m/s" /> 
    274         <field id="hbl"                 long_name="boundary layer depth"                     unit="m"       /> 
    275         <field id="hbli"                long_name="initial boundary layer depth"             unit="m"       /> 
    276         <field id="dstokes"             long_name="stokes drift  depth scale"                unit="m"       /> 
    277         <field id="zustke"              long_name="magnitude of stokes drift  at T-points"   unit="m/s"     /> 
    278287        <field id="zwstrc"              long_name="convective velocity scale"                unit="m/s"     /> 
     288        <field id="zustar"              long_name="friction velocity"                        unit="m/s"     /> 
    279289        <field id="zwstrl"              long_name="langmuir velocity scale"                  unit="m/s"     /> 
    280         <field id="zustar"              long_name="friction velocity"                        unit="m/s"     /> 
    281         <field id="zhbl"                long_name="boundary layer depth"                     unit="m"       /> 
    282         <field id="zhml"                long_name="mixed layer depth"                        unit="m"       /> 
     290        <field id="zvstr"               long_name="mixed velocity scale"                     unit="m/s"     /> 
     291        <field id="zla"                 long_name="langmuir number"                          unit="m/s"     /> 
    283292        <field id="wind_wave_abs_power" long_name="\rho |U_s| x u*^2"                        unit="mW"      /> 
    284293        <field id="wind_wave_power"     long_name="U_s \dot  tau"                            unit="mW"      /> 
    285294        <field id="wind_power"          long_name="\rho  u*^3"                               unit="mW"      /> 
    286295 
    287         <!-- extra OSMOSIS diagnostics --> 
     296       <!-- interior BL OSMOSIS diagnostics --> 
    288297        <field id="zwthav"              long_name="av turb flux of T in ml"                  unit="deg m/s" /> 
    289298        <field id="zt_ml"               long_name="av T in ml"                               unit="deg"     /> 
     299        <field id="zhol"                long_name="Hoenekker number"                         unit="#"       /> 
     300        <field id="zws_ent"            long_name="entrainment turb flux of S"                unit="10^-3 m/s" /> 
    290301        <field id="zwth_ent"            long_name="entrainment turb flux of T"               unit="deg m/s" /> 
    291         <field id="zhol"                long_name="Hoenekker number"                         unit="#"       /> 
    292         <field id="zdh"                 long_name="Pycnocline  depth - grid"                 unit=" m"      /> 
    293       </field_group> 
    294  
    295       <field_group id="OSMOSIS_W" grid_ref="grid_W_3D" operation="instant" > 
     302        <field id="zwb_ent"            long_name="entrainment turb flux of buoyancy"         unit="m^2/s^-3" /> 
     303  
     304        <field id="zdt_bl"             long_name="temperature jump at base of BL"                 unit="deg"      /> 
     305        <field id="zds_bl"             long_name="salinity jump at base of BL"                 unit="10^-3"      /> 
     306        <field id="zdb_bl"             long_name="buoyancy jump at base of BL"                 unit="m/s^2"      /> 
     307        <field id="zdu_bl"             long_name="u jump at base of BL"                       unit="m/s"      /> 
     308        <field id="zdv_bl"             long_name="v jump at base of BL"                       unit="m/s"      /> 
     309 
     310        <!-- extra OSMOSIS diagnostics for debugging --> 
     311       <field id="zsc_uw_1_0"       long_name="zsc u-momentum flux on T after Stokes"                       unit="m^2/s^2" /> 
     312        <field id="zsc_uw_1_f"       long_name="zsc u-momentum flux on T after Coriolis"                       unit="m^2/s^2" /> 
     313        <field id="zsc_vw_1_f"       long_name="zsc v-momentum flux on T after Coriolis"                       unit="m^2/s^2" /> 
     314        <field id="zsc_uw_2_f"       long_name="2nd zsc u-momentum flux on T after Coriolis"                       unit="m^2/s^2" /> 
     315        <field id="zsc_vw_2_f"       long_name="2nd zsc v-momentum flux on T after Coriolis"                       unit="m^2/s^2" /> 
     316        <field id="zuw_bse"       long_name="base u-flux T-points"                          unit="m^2/s^2" /> 
     317        <field id="zvw_bse"       long_name="base v-flux T-points"                          unit="m^2/s^2" /> 
     318 
     319       <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 
     320         <field id="hmle"          long_name="OBL FK-layer thickness"                                     unit="m"        /> 
     321        <field id="mld_prof"              long_name="FK-layer depth index"                  unit="#" /> 
     322        <field id="zmld"          long_name="target FK-layer thickness"                                     unit="m"        /> 
     323        <field id="zwb_fk"          long_name="FK b-flux"                                     unit="m^2 s^-3"        /> 
     324        <field id="zwb_fk_b"          long_name="layer averaged FK b-flux"                 unit="m^2 s^-3"       /> 
     325        <field id="zdiff_mle"          long_name="max FK diffusivity in MLE"       unit=" 10^-4 m^2 s^-1"       /> 
     326        <field id="zvel_mle"          long_name="FK velocity scale in MLE"       unit=" m s^-1"       /> 
     327    </field_group> 
     328 
     329      <field_group id="OSMOSIS_W" grid_ref="grid_W_3D" > 
     330        <field id="zviscos"       long_name="BL viscosity"   unit="m^2/s" /> 
    296331        <field id="ghamt"       long_name="non-local temperature flux"                       unit="deg m/s" /> 
    297332        <field id="ghams"       long_name="non-local salinity flux"                          unit="psu m/s" /> 
    298333        <field id="zdtdz_pyc"   long_name="Pycnocline temperature gradient"                  unit=" deg/m"  /> 
    299       </field_group> 
     334        <field id="zdsdz_pyc"   long_name="Pycnocline salinity gradient"                  unit=" 10^-3/m"  /> 
     335        <field id="zdbdz_pyc"   long_name="Pycnocline buoyancy gradient"                  unit=" s^-2"  /> 
     336        <field id="zdudz_pyc"   long_name="Pycnocline u gradient"                  unit=" s^-2"  /> 
     337        <field id="zdvdz_pyc"   long_name="Pycnocline v gradient"                  unit=" s^-2"  /> 
     338 
     339        <!-- extra OSMOSIS diagnostics for debugging --> 
     340         <field id="ghamu_00"       long_name="initial non-local u-momentum flux"   unit="m^2/s^2" /> 
     341        <field id="ghamv_00"       long_name="initial non-local v-momentum flux"   unit="m^2/s^2" /> 
     342        <field id="ghamu_0"       long_name="after dstokes non-local u-momentum flux"   unit="m^2/s^2" /> 
     343        <field id="ghamu_f"       long_name="after Coriolis non-local u-momentum flux"   unit="m^2/s^2" /> 
     344        <field id="ghamv_f"       long_name="after Coriolis  non-local v-momentum flux"   unit="m^2/s^2" /> 
     345        <field id="ghamu_b"       long_name="after buoyancy added non-local u-momentum flux"   unit="m^2/s^2" /> 
     346        <field id="ghamv_b"       long_name="after buoyancy added  non-local v-momentum flux"  unit="m^2/s^2" /> 
     347        <field id="ghamu_1"       long_name="after entrainment non-local u-momentum flux"   unit="m^2/s^2" /> 
     348        <field id="ghamv_1"       long_name="after entrainment  non-local v-momentum flux"  unit="m^2/s^2" /> 
     349     </field_group> 
    300350 
    301351      <field_group id="OSMOSIS_U" grid_ref="grid_U_2D" > 
    302352        <field id="ghamu"       long_name="non-local u-momentum flux"   grid_ref="grid_U_3D" unit="m^2/s^2" /> 
    303         <field id="us_x"        long_name="i component of Stokes drift"                      unit="m/s"     /> 
    304       </field_group> 
     353       <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 
     354       <field id="zdtdx"          long_name="FK  T x-gradient"                                     unit=" deg C m^-1"        /> 
     355        <field id="zdsdx"          long_name="FK  S x-gradient"                                     unit=" 10^-3 m^-1"        /> 
     356        <field id="dbdx_mle"          long_name="FK  B x-gradient"                                     unit=" s^-2"        /> 
     357     </field_group> 
    305358 
    306359      <field_group id="OSMOSIS_V" grid_ref="grid_V_2D" > 
    307360        <field id="ghamv"       long_name="non-local v-momentum flux"   grid_ref="grid_V_3D" unit="m^2/s^2" /> 
    308         <field id="us_y"        long_name="j component of Stokes drift"                      unit="m/s"     /> 
     361        <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 
     362        <field id="zdtdy"          long_name="FK T y-gradient"                                     unit=" deg C m^-1"        /> 
     363        <field id="zdsdy"          long_name="FK S y-gradient"                                     unit=" 10^-3 m^-1"        /> 
     364        <field id="dbdy_mle"          long_name="FK B y-gradient"                                     unit=" s^-2"        /> 
    309365      </field_group> 
    310366 
    … …  
    501557 
    502558      <field_group id="grid_U"   grid_ref="grid_U_2D"> 
     559        <field id="hu"            long_name="water column height at U point"                         standard_name="water_column_height_U"       unit="m" /> 
    503560        <field id="e2u"           long_name="U-cell width in meridional direction"                   standard_name="cell_width"                  unit="m"                               /> 
    504561        <field id="e3u"           long_name="U-cell thickness"                                       standard_name="cell_thickness"              unit="m"          grid_ref="grid_U_3D" /> 
    … …  
    571628        <field id="e3v"          long_name="V-cell thickness"                                       standard_name="cell_thickness"              unit="m"          grid_ref="grid_V_3D" /> 
    572629        <field id="e3v_0"        long_name="Initial V-cell thickness"                               standard_name="ref_cell_thickness"          unit="m"          grid_ref="grid_V_3D" /> 
     630        <field id="hv"            long_name="water column height at V point"                        standard_name="water_column_height_V"       unit="m" /> 
    573631        <field id="vtau"         long_name="Wind Stress along j-axis"                               standard_name="surface_downward_y_stress"   unit="N/m2"                            /> 
    574632        <field id="voce"         long_name="ocean current along j-axis"                             standard_name="sea_water_y_velocity"        unit="m/s"        grid_ref="grid_V_3D" /> 
    … …  
    679737 
    680738      <!-- F grid --> 
     739      <field_group id="grid_F" grid_ref="grid_F_2D"> 
     740   <field id="e3f"          long_name="F-cell thickness"                    standard_name="cell_thickness"        unit="m"   grid_ref="grid_F_3D" /> 
     741   <field id="e3f_0"        long_name="F-cell thickness"                    standard_name="cell_thickness"        unit="m"   grid_ref="grid_F_3D" /> 
     742        <field id="hf"           long_name="water column height at F point"    standard_name="water_column_height_F"  unit="m"                     /> 
     743        <field id="sKEf"         long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water"   unit="m2/s2" /> 
     744        <field id="relvor"       long_name="relative vorticity"                standard_name="relative_vorticity"     unit="1/s"                   /> 
     745        <field id="plavor"       long_name="planetary vorticity"               standard_name="planetary_vorticity"    unit="1/s"                   /> 
     746        <field id="relpotvor"    long_name="relative potential vorticity"      standard_name="relpot_vorticity"       unit="1/m.s"                 /> 
     747        <field id="abspotvor"    long_name="absolute potential vorticity"      standard_name="abspot_vorticity"       unit="1/m.s"                 /> 
     748        <field id="Ens"          long_name="enstrophy"                         standard_name="enstrophy"              unit="1/m2.s2"               /> 
     749      </field_group>  
     750  
    681751      <!-- AGRIF sponge --> 
    682752      <field id="agrif_spf"    long_name=" AGRIF f-sponge coefficient"   unit=" " /> 
    … …  
    841911     <field id="strd_zdfp"     long_name="salinity   -trend: pure vert. diffusion"   unit="1e-3/s" /> 
    842912 
    843      <!-- --> 
     913     <!-- ln_zdfosm=T only (OSMOSIS-OBL) --> 
     914     <field id="ttrd_osm"      long_name="temperature-trend: OSM-OSBL non-local forcing"                             unit="degC/s" /> 
     915     <field id="strd_osm"      long_name="salinity   -trend: OSM-OSBL non-local forcing"                             unit="1e-3/s" /> 
     916 
     917 
     918    <!-- --> 
    844919     <field id="ttrd_dmp"      long_name="temperature-trend: interior restoring"        unit="degC/s" /> 
    845920     <field id="strd_dmp"      long_name="salinity   -trend: interior restoring"        unit="1e-3/s" /> 
    … …  
    877952     <field id="strd_zdfp_e3t"     unit="1e-3/s * m"  >  strd_zdfp * e3t </field> 
    878953 
     954          <!-- ln_zdfosm=T only (OSMOSIS-OBL) --> 
     955     <field id="ttrd_osm_e3t"      long_name="temperature-trend: OSM-OSBL non-local forcing"                             unit="degC/s * m" >  ttrd_osm * e3t </field> 
     956     <field id="strd_osm_e3t"      long_name="salinity   -trend: OSM-OSBL non-local forcing"                             unit="1e-3/s * m" >  strd_osm * e3t </field> 
     957      
    879958     <!-- --> 
    880959     <field id="ttrd_dmp_e3t"      unit="degC/s * m"  >  ttrd_dmp * e3t </field> 
    … …  
    892971     <field id="ttrd_totad_li"    long_name="layer integrated heat-trend: total advection"         unit="W/m^2"     > ttrd_totad_e3t * 1026.0 * 3991.86795711963 </field> 
    893972     <field id="strd_totad_li"    long_name="layer integrated salt-trend: total advection"         unit="kg/(m^2 s)"    > strd_totad_e3t * 1026.0 * 0.001  </field> 
     973     <field id="ttrd_osm_li"    long_name="layer integrated heat-trend: non-local OSM"         unit="W/m^2"     > ttrd_osm_e3t * 1026.0 * 3991.86795711963 </field> 
     974     <field id="strd_osm_li"    long_name="layer integrated salt-trend: non-local OSM"         unit="kg/(m^2 s)"    > strd_osm_e3t * 1026.0 * 0.001  </field> 
    894975     <field id="ttrd_evd_li"      long_name="layer integrated heat-trend: EVD convection"          unit="W/m^2"    > ttrd_evd_e3t * 1026.0 * 3991.86795711963 </field> 
    895976     <field id="strd_evd_li"      long_name="layer integrated salt-trend: EVD convection"          unit="kg/(m^2 s)"  > strd_evd_e3t * 1026.0 * 0.001  </field> 
    … …  
    10991180    </field_group> 
    11001181 
     1182    <!-- TMB diagnostic output --> 
     1183    <field_group  id="1h_grid_T_tmb" grid_ref="grid_T_2D" operation="instant"> 
     1184      <field id="top_temp"           name="votemper_top"  unit="degC"  /> 
     1185      <field id="mid_temp"           name="votemper_mid"  unit="degC"  /> 
     1186      <field id="bot_temp"           name="votemper_bot"  unit="degC"  /> 
     1187      <field id="top_sal"            name="vosaline_top"  unit="psu"   /> 
     1188      <field id="mid_sal"            name="vosaline_mid"  unit="psu"   /> 
     1189      <field id="bot_sal"            name="vosaline_bot"  unit="psu"   /> 
     1190      <field id="sshnmasked"         name="sossheig"      unit="m"     />  
     1191    </field_group> 
     1192 
    11011193    <field_group  id="1h_grid_U_tmb" grid_ref="grid_U_2D" operation="instant"> 
    11021194      <field id="top_u"           name="vozocrtx_top"  unit="m/s"  /> 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/grid_def_nemo.xml

    r12377 r14062  
    5353         <domain domain_ref="grid_W" /> 
    5454         <axis axis_ref="depthw" /> 
     55       </grid> 
     56       <!--  --> 
     57       <grid id="grid_F_2D" > 
     58         <domain domain_ref="grid_F" /> 
     59       </grid> 
     60        <!--  --> 
     61       <grid id="grid_F_3D" > 
     62         <domain domain_ref="grid_F" /> 
     63         <axis axis_ref="depthf" /> 
    5564       </grid> 
    5665        <!--  --> 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/namelist_ref

    r14044 r14062  
    998998   ln_dynvor_eeT = .false. !  energy conserving scheme (een using e3t) 
    999999   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    1000       nn_een_e3f = 0          ! =0  e3f = mi(mj(e3t))/4 
    1001       !                       ! =1  e3f = mi(mj(e3t))/mi(mj( tmask)) 
     1000   ! 
    10021001   ln_dynvor_msk = .false. !  vorticity multiplied by fmask (=T)        ==>>> PLEASE DO NOT ACTIVATE 
    1003       !                    !  (f-point vorticity schemes only) 
     1002   !                       !  (f-point vorticity schemes only) 
     1003   ! 
     1004   nn_e3f_typ = 0          !  type of e3f (EEN, ENE, ENS, MIX only)  =0  e3f = mi(mj(e3t))/4 
     1005   !                       !                                         =1  e3f = mi(mj(e3t))/mi(mj( tmask)) 
    10041006/ 
    10051007!----------------------------------------------------------------------- 
    … …  
    10111013   ln_hpg_isf  = .false.   !  s-coordinate (sco ) adapted to isf 
    10121014   ln_hpg_djc  = .false.   !  s-coordinate (Density Jacobian with Cubic polynomial) 
     1015      ln_hpg_djc_vnh = .true.  !  hor.  bc type for djc scheme (T=von Neumann, F=linear extrapolation) 
     1016      ln_hpg_djc_vnv = .true.  !  vert. bc type for djc scheme (T=von Neumann, F=linear extrapolation) 
    10131017   ln_hpg_prj  = .false.   !  s-coordinate (Pressure Jacobian scheme) 
    10141018/ 
    … …  
    10331037   !                       !  Type of the operator : 
    10341038   ln_dynldf_OFF = .false.     !  No operator (i.e. no explicit diffusion) 
     1039   nn_dynldf_typ = 0           !  =0 div-rot (default)   ;   =1 symmetric 
    10351040   ln_dynldf_lap = .false.     !    laplacian operator 
    10361041   ln_dynldf_blp = .false.     !  bilaplacian operator 
    … …  
    11631168   ln_mxl0     = .true.    !  surface mixing length scale = F(wind stress) (T) or not (F) 
    11641169      nn_mxlice    = 2        ! type of scaling under sea-ice 
    1165                               !    = 0 no scaling under sea-ice 
    1166                               !    = 1 scaling with constant sea-ice thickness 
    1167                               !    = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) 
    1168                               !    = 3 scaling with maximum sea-ice thickness 
     1170      !                       !    = 0 no scaling under sea-ice 
     1171      !                       !    = 1 scaling with constant sea-ice thickness 
     1172      !                       !    = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) 
     1173      !                       !    = 3 scaling with maximum sea-ice thickness 
    11691174      rn_mxlice   = 10.       ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) 
    11701175   rn_mxl0     =   0.04    !  surface  buoyancy lenght scale minimum value 
    … …  
    11731178      rn_lc       =   0.15    !  coef. associated to Langmuir cells 
    11741179   nn_etau     =   1       !  penetration of tke below the mixed layer (ML) due to NIWs 
    1175                               !        = 0 none ; = 1 add a tke source below the ML 
    1176                               !        = 2 add a tke source just at the base of the ML 
    1177                               !        = 3 as = 1 applied on HF part of the stress           (ln_cpl=T) 
     1180   !                          !        = 0 none ; = 1 add a tke source below the ML 
     1181   !                          !        = 2 add a tke source just at the base of the ML 
     1182   !                          !        = 3 as = 1 applied on HF part of the stress           (ln_cpl=T) 
    11781183      rn_efr      =   0.05    !  fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) 
    11791184      nn_htau     =   1       !  type of exponential decrease of tke penetration below the ML 
    1180                               !        = 0  constant 10 m length scale 
    1181                               !        = 1  0.5m at the equator to 30m poleward of 40 degrees 
     1185      !                       !        = 0  constant 10 m length scale 
     1186      !                       !        = 1  0.5m at the equator to 30m poleward of 40 degrees 
    11821187   nn_eice     =   1       !  attenutaion of langmuir & surface wave breaking under ice 
    11831188   !                       !           = 0 no impact of ice cover on langmuir & surface wave breaking 
    … …  
    12161221&namzdf_osm    !   OSM vertical diffusion                               (ln_zdfosm =T) 
    12171222!----------------------------------------------------------------------- 
    1218    ln_use_osm_la = .false.      !  Use namelist  rn_osm_la 
     1223   ln_use_osm_la = .false.     !  Use   rn_osm_la 
    12191224   rn_osm_la     = 0.3         !  Turbulent Langmuir number 
    1220    rn_osm_dstokes     = 5.     !  Depth scale of Stokes drift (m) 
     1225   rn_zdfosm_adjust_sd = 1.0   ! Stokes drift reduction factor 
     1226   rn_osm_hblfrac = 0.1        ! specify top part of hbl for nn_osm_wave = 3 or 4 
     1227   rn_osm_bl_thresh   = 5.e-5      !Threshold buoyancy for deepening of OSBL base 
    12211228   nn_ave = 0                  ! choice of horizontal averaging on avt, avmu, avmv 
    12221229   ln_dia_osm = .true.         ! output OSMOSIS-OBL variables 
    … …  
    12261233   rn_difri  =  0.005          ! max Ri# diffusivity at Ri_g = 0 (m^2/s) 
    12271234   ln_convmix  = .true.        ! Use convective instability mixing below BL 
    1228    rn_difconv = 1.             ! diffusivity when unstable below BL  (m2/s) 
     1235   rn_difconv = 1. !0.01 !1.             ! diffusivity when unstable below BL  (m2/s) 
     1236   rn_osm_dstokes     = 5.     !  Depth scale of Stokes drift (m) 
    12291237   nn_osm_wave = 0             ! Method used to calculate Stokes drift 
    12301238      !                        !  = 2: Use ECMWF wave fields 
    12311239      !                        !  = 1: Pierson Moskowitz wave spectrum 
    12321240      !                        !  = 0: Constant La# = 0.3 
    1233 / 
     1241   nn_osm_SD_reduce = 0        ! Method used to get active Stokes drift from surface value 
     1242      !                        !  = 0: No reduction 
     1243                               !  = 1: use SD avged over top 10% hbl 
     1244                               !  = 2:use surface value of SD fit to slope at rn_osm_hblfrac*hbl below surface 
     1245   ln_zdfosm_ice_shelter = .true.  ! reduce surface SD and depth scale under ice 
     1246   ln_osm_mle = .false.        !  Use integrated FK-OSM model 
     1247/ 
     1248!----------------------------------------------------------------------- 
     1249&namosm_mle    !   mixed layer eddy parametrisation (Fox-Kemper)       (default: OFF) 
     1250!----------------------------------------------------------------------- 
     1251   rn_osm_mle_ce       = 0.06      ! magnitude of the MLE (typical value: 0.06 to 0.08) 
     1252   nn_osm_mle          = 0         ! MLE type: =0 standard Fox-Kemper ; =1 new formulation 
     1253   rn_osm_mle_lf       = 5.e+3     ! typical scale of mixed layer front (meters)                      (case rn_osm_mle=0) 
     1254   rn_osm_mle_time     = 172800.   ! time scale for mixing momentum across the mixed layer (seconds)  (case rn_osm_mle=0) 
     1255   rn_osm_mle_lat      = 20.       ! reference latitude (degrees) of MLE coef.                        (case rn_mle=1) 
     1256   rn_osm_mle_rho_c =    0.01      ! delta rho criterion used to calculate MLD for FK 
     1257   rn_osm_mle_thresh  = 0.0005     ! delta b criterion used for FK MLE criterion 
     1258   rn_osm_mle_tau     = 172800.    ! time scale for FK-OSM (seconds)  (case rn_osm_mle=0) 
     1259   ln_osm_hmle_limit   = .false.   ! limit hmle to rn_osm_hmle_limit*hbl 
     1260   rn_osm_hmle_limit   = 1.2 
     1261   / 
    12341262!----------------------------------------------------------------------- 
    12351263&namzdf_mfc     !   Mass Flux Convection 
    … …  
    13741402   ln_sstnight = .false.             ! Logical switch for calculating night-time average for SST obs 
    13751403   ln_bound_reject  = .false.        ! Logical to remove obs near boundaries in LAMs. 
     1404   ln_default_fp_indegs = .true.     ! Logical: T=> averaging footprint is in degrees, F=> in metres 
    13761405   ln_sla_fp_indegs = .true.         ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 
    13771406   ln_sst_fp_indegs = .true.         ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres 
    … …  
    13891418   cn_gridsearchfile ='gridsearch.nc' ! Grid search file name 
    13901419   rn_gridsearchres = 0.5            ! Grid search resolution 
     1420   rn_default_avglamscl = 0.         ! Default E/W diameter of observation footprint (metres/degrees) 
     1421   rn_default_avgphiscl = 0.         ! Default N/S diameter of observation footprint (metres/degrees) 
    13911422   rn_mdtcorr  = 1.61                ! MDT  correction 
    13921423   rn_mdtcutoff = 65.0               ! MDT cutoff for computed correction 
    … …  
    14021433   rn_sic_avgphiscl = 0.             ! N/S diameter of SIC observation footprint (metres/degrees) 
    14031434   nn_1dint = 0                      ! Type of vertical interpolation method 
    1404    nn_2dint = 0                      ! Default horizontal interpolation method 
     1435   nn_2dint_default = 0              ! Default horizontal interpolation method 
    14051436   nn_2dint_sla = 0                  ! Horizontal interpolation method for SLA 
    14061437   nn_2dint_sst = 0                  ! Horizontal interpolation method for SST 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/doc/namelists/namobs

    r11703 r14062  
    2020   ln_sstnight = .false.             ! Logical switch for calculating night-time average for SST obs 
    2121   ln_bound_reject  = .false.        ! Logical to remove obs near boundaries in LAMs. 
     22   ln_default_fp_indegs = .true.     ! Logical: T=> averaging footprint is in degrees, F=> in metres 
    2223   ln_sla_fp_indegs = .true.         ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 
    2324   ln_sst_fp_indegs = .true.         ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres 
    … …  
    3940   rn_dobsini  = 00010101.000000     ! Initial date in window YYYYMMDD.HHMMSS 
    4041   rn_dobsend  = 00010102.000000     ! Final date in window YYYYMMDD.HHMMSS 
     42   rn_default_avglamscl = 0.         ! Default E/W diameter of observation footprint (metres/degrees) 
     43   rn_default_avgphiscl = 0.         ! Default N/S diameter of observation footprint (metres/degrees) 
    4144   rn_sla_avglamscl = 0.             ! E/W diameter of SLA observation footprint (metres/degrees) 
    4245   rn_sla_avgphiscl = 0.             ! N/S diameter of SLA observation footprint (metres/degrees) 
    … …  
    4851   rn_sic_avgphiscl = 0.             ! N/S diameter of SIC observation footprint (metres/degrees) 
    4952   nn_1dint = 0                      ! Type of vertical interpolation method 
    50    nn_2dint = 0                      ! Default horizontal interpolation method 
     53   nn_2dint_default = 0              ! Default horizontal interpolation method 
    5154   nn_2dint_sla = 0                  ! Horizontal interpolation method for SLA 
    5255   nn_2dint_sst = 0                  ! Horizontal interpolation method for SST 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/ICE/iceistate.F90

    r14037 r14062  
    2121   USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 
    2222   USE eosbn2         ! equation of state 
     23# if defined key_qco 
     24   USE domqco         ! Variable volume 
     25# else 
    2326   USE domvvl         ! Variable volume 
     27# endif 
    2428   USE ice            ! sea-ice: variables 
    2529   USE ice1D          ! sea-ice: thermodynamics variables 
    … …  
    434438         ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 
    435439         ! 
     440#if defined key_qco 
     441         IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm )        ! interpolation scale factor, depth and water column 
     442#else 
    436443         IF( .NOT.ln_linssh )   CALL dom_vvl_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 
    437 ! !!st 
    438 !          IF( .NOT.ln_linssh ) THEN 
    439 !             ! 
    440 !             WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 
    441 !             ELSEWHERE                ;   z2d(:,:) = 1._wp   ;   END WHERE 
    442 !             ! 
    443 !             DO jk = 1,jpkm1                     ! adjust initial vertical scale factors 
    444 !                e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 
    445 !                e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
    446 !                e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 
    447 !             END DO 
    448 !             ! 
    449 !             ! Reconstruction of all vertical scale factors at now and before time-steps 
    450 !             ! ========================================================================= 
    451 !             ! Horizontal scale factor interpolations 
    452 !             ! -------------------------------------- 
    453 !             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 
    454 !             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 
    455 !             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
    456 !             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
    457 !             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 
    458 !             ! Vertical scale factor interpolations 
    459 !             ! ------------------------------------ 
    460 !             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  ) 
    461 !             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 
    462 !             CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 
    463 !             CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
    464 !             CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
    465 !             ! t- and w- points depth 
    466 !             ! ---------------------- 
    467 !             !!gm not sure of that.... 
    468 !             gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 
    469 !             gdepw(:,:,1,Kmm) = 0.0_wp 
    470 !             gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 
    471 !             DO jk = 2, jpk 
    472 !                gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk  ,Kmm) 
    473 !                gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 
    474 !                gde3w(:,:,jk) = gdept(:,:,jk  ,Kmm) - ssh (:,:,Kmm) 
    475 !             END DO 
    476 !          ENDIF 
     444#endif 
     445 
    477446      ENDIF 
    478447 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_interp.F90

    r13286 r14062  
    2828   USE agrif_oce 
    2929   USE phycst 
    30    USE dynspg_ts, ONLY: un_adv, vn_adv 
     30!!!   USE dynspg_ts, ONLY: un_adv, vn_adv 
    3131   ! 
    3232   USE in_out_manager 
    … …  
    5050   INTEGER ::   bdy_tinterp = 0 
    5151 
    52    !!---------------------------------------------------------------------- 
     52   !! * Substitutions 
     53#  include "domzgr_substitute.h90" 
    5354   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    5455   !! $Id$ 
    … …  
    11921193      !!----------------------------------------------------------------------   
    11931194      IF( before ) THEN 
    1194          IF ( ln_bt_fw ) THEN 
     1195!         IF ( ln_bt_fw ) THEN 
    11951196            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 
    1196          ELSE 
    1197             ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 
    1198          ENDIF 
     1197!         ELSE 
     1198!            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 
     1199!         ENDIF 
    11991200      ELSE 
    12001201         zrhot = Agrif_rhot() 
    … …  
    12281229      ! 
    12291230      IF( before ) THEN 
    1230          IF ( ln_bt_fw ) THEN 
     1231!         IF ( ln_bt_fw ) THEN 
    12311232            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 
    1232          ELSE 
    1233             ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 
    1234          ENDIF 
     1233!         ELSE 
     1234!            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 
     1235!         ENDIF 
    12351236      ELSE       
    12361237         zrhot = Agrif_rhot() 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_sponge.F90

    r13312 r14062  
    3232 
    3333   !! * Substitutions 
     34#  include "domzgr_substitute.h90" 
    3435#  include "do_loop_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_update.F90

    r13782 r14062  
    2727   USE vremap         ! Vertical remapping 
    2828   USE lbclnk  
    29  
     29#if defined key_qco 
     30   USE domqco 
     31#endif 
    3032   IMPLICIT NONE 
    3133   PRIVATE 
    … …  
    3436   PUBLIC   Update_Scales 
    3537 
     38   !! * Substitutions 
     39#  include "domzgr_substitute.h90" 
    3640   !!---------------------------------------------------------------------- 
    3741   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    … …  
    191195   END SUBROUTINE Agrif_Update_Tke 
    192196 
    193  
    194197   SUBROUTINE Agrif_Update_vvl( ) 
    195198      !!--------------------------------------------- 
    … …  
    201204      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 
    202205      ! 
     206#if ! defined key_qco 
    203207      Agrif_UseSpecialValueInUpdate = .TRUE. 
    204208      Agrif_SpecialValueFineGrid = 0. 
    … …  
    213217      CALL dom_vvl_update_UVF 
    214218      CALL Agrif_ParentGrid_To_ChildGrid() 
     219#else 
     220      CALL Agrif_ChildGrid_To_ParentGrid() 
     221      CALL Agrif_Update_qco 
     222      CALL Agrif_ParentGrid_To_ChildGrid() 
     223#endif 
    215224      ! 
    216225   END SUBROUTINE Agrif_Update_vvl 
    217226 
     227 
     228#if defined key_qco 
     229   SUBROUTINE Agrif_Update_qco 
     230      !!--------------------------------------------- 
     231      !!       *** ROUTINE dom_Update_qco *** 
     232      !!--------------------------------------------- 
     233      ! 
     234      ! Save arrays prior update (needed for asselin correction) 
     235      r3t(:,:,Krhs_a) = r3t(:,:,Kmm_a) 
     236      r3u(:,:,Krhs_a) = r3u(:,:,Kmm_a) 
     237      r3v(:,:,Krhs_a) = r3v(:,:,Kmm_a) 
     238 
     239      ! Update r3x arrays from updated ssh 
     240      CALL dom_qco_zgr( Kbb_a, Kmm_a ) 
     241      ! 
     242   END SUBROUTINE Agrif_Update_qco 
     243#endif 
     244 
     245 
     246#if ! defined key_qco 
    218247   SUBROUTINE dom_vvl_update_UVF 
    219248      !!--------------------------------------------- 
    … …  
    224253      REAL(wp):: zcoef 
    225254      !!--------------------------------------------- 
    226  
    227255      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & 
    228256                  & Agrif_Fixed(), 'Step', Agrif_Nb_Step() 
    … …  
    290318      ! 
    291319   END SUBROUTINE dom_vvl_update_UVF 
     320#endif 
    292321 
    293322#if defined key_vertical 
    … …  
    13361365   END SUBROUTINE updateAVM 
    13371366 
     1367#if ! defined key_qco 
    13381368   SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 
    13391369      !!--------------------------------------------- 
    … …  
    14471477      ! 
    14481478   END SUBROUTINE updatee3t 
     1479#endif 
    14491480 
    14501481#else 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_user.F90

    r14037 r14062  
    288288         CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh) 
    289289         CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. ) 
     290#if ! defined key_qco 
    290291         DO jk = 1, jpk 
    291292               e3t(:,:,jk,Kbb) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb)  ) & 
    … …  
    293294                        &              + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 
    294295         END DO 
     296#endif 
    295297      ENDIF 
    296298 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DIA/diawri.F90

    r14037 r14062  
    1919   !!            3.7  ! 2014-01  (G. Madec) remove eddy induced velocity from no-IOM output 
    2020   !!                 !                     change name of output variables in dia_wri_state 
     21   !!            4.0  ! 2020-10  (A. Nasser, S. Techene) add diagnostic for SWE 
    2122   !!---------------------------------------------------------------------- 
    2223 
    … …  
    4647   USE zdfdrg         ! ocean vertical physics: top/bottom friction 
    4748   USE zdfmxl         ! mixed layer 
     49   USE zdfosm         ! mixed layer 
    4850   ! 
    4951   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    … …  
    118120      INTEGER ::   ji, jj, jk       ! dummy loop indices 
    119121      INTEGER ::   ikbot            ! local integer 
    120       REAL(wp)::   ze3 
    121122      REAL(wp)::   zztmp , zztmpx   ! local scalar 
    122123      REAL(wp)::   zztmp2, zztmpy   !   -      - 
     124      REAL(wp)::   ze3 
    123125      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d   ! 2D workspace 
    124126      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   z3d   ! 3D workspace 
    … …  
    137139      CALL iom_put("e3u_0", e3u_0(:,:,:) ) 
    138140      CALL iom_put("e3v_0", e3v_0(:,:,:) ) 
     141      CALL iom_put("e3f_0", e3f_0(:,:,:) ) 
    139142      ! 
    140143      IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN  ! time-varying e3t 
    … …  
    163166         CALL iom_put( "e3w" , z3d(:,:,:) ) 
    164167      ENDIF 
     168      IF ( iom_use("e3f") ) THEN                         ! time-varying e3f caution here at Kaa 
     169          DO jk = 1, jpk 
     170            z3d(:,:,jk) =  e3f(:,:,jk) 
     171         END DO 
     172         CALL iom_put( "e3f" , z3d(:,:,:) ) 
     173      ENDIF 
    165174 
    166175      IF( ll_wd ) THEN                                   ! sea surface height (brought back to the reference used for wetting and drying) 
    167          CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) 
     176         CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*ssmask(:,:) ) 
    168177      ELSE 
    169178         CALL iom_put( "ssh" , ssh(:,:,Kmm) )              ! sea surface height 
    170179      ENDIF 
    171180 
    172       IF( iom_use("wetdep") )   &                  ! wet depth 
    173          CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) 
     181      IF( iom_use("wetdep") )    CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) )   ! wet depth 
     182          
     183#if defined key_qco 
     184      IF( iom_use("ht") )   CALL iom_put( "ht" , ht(:,:)     )   ! water column at t-point 
     185      IF( iom_use("hu") )   CALL iom_put( "hu" , hu(:,:,Kmm) )   ! water column at u-point 
     186      IF( iom_use("hv") )   CALL iom_put( "hv" , hv(:,:,Kmm) )   ! water column at v-point 
     187      IF( iom_use("hf") )   CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) )   ! water column at f-point (caution here at Naa) 
     188#endif 
    174189       
    175190      CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) )    ! 3D temperature 
    … …  
    325340      ENDIF 
    326341      ! 
     342      IF ( iom_use("sKE") ) THEN                        ! surface kinetic energy at T point 
     343         z2d(:,:) = 0._wp 
     344         DO_2D( 0, 0, 0, 0 ) 
     345            z2d(ji,jj) = 0.25_wp * ( uu(ji  ,jj,1,Kmm) * uu(ji  ,jj,1,Kmm) * e1e2u(ji  ,jj) * e3u(ji  ,jj,1,Kmm)  & 
     346               &                   + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm)  & 
     347               &                   + vv(ji,jj  ,1,Kmm) * vv(ji,jj  ,1,Kmm) * e1e2v(ji,jj  ) * e3v(ji,jj  ,1,Kmm)  &  
     348               &                   + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm)  )  & 
     349               &                 * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj) 
     350         END_2D 
     351         CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 
     352         IF ( iom_use("sKE" ) )  CALL iom_put( "sKE" , z2d )    
     353      ENDIF 
     354      !     
     355      IF ( iom_use("sKEf") ) THEN                        ! surface kinetic energy at F point 
     356         z2d(:,:) = 0._wp                                ! CAUTION : only valid in SWE, not with bathymetry 
     357         DO_2D( 0, 0, 0, 0 ) 
     358            z2d(ji,jj) = 0.25_wp * ( uu(ji,jj  ,1,Kmm) * uu(ji,jj  ,1,Kmm) * e1e2u(ji,jj  ) * e3u(ji,jj  ,1,Kmm)  & 
     359               &                   + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm)  & 
     360               &                   + vv(ji  ,jj,1,Kmm) * vv(ji,jj  ,1,Kmm) * e1e2v(ji  ,jj) * e3v(ji  ,jj,1,Kmm)  &  
     361               &                   + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm)  )  & 
     362               &                 * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj) 
     363         END_2D 
     364         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
     365         CALL iom_put( "sKEf", z2d )                      
     366      ENDIF 
     367      ! 
    327368      CALL iom_put( "hdiv", hdiv )                  ! Horizontal divergence 
    328369 
    … …  
    424465       
    425466      IF (ln_dia25h)   CALL dia_25h( kt, Kmm )        ! 25h averaging 
     467       
     468      ! Output of vorticity terms 
     469      IF ( iom_use("relvor")    .OR. iom_use("plavor")    .OR.   & 
     470         & iom_use("relpotvor") .OR. iom_use("abspotvor") .OR.   & 
     471         & iom_use("Ens")                                        ) THEN 
     472         ! 
     473         z2d(:,:) = 0._wp  
     474         ze3 = 0._wp  
     475         DO_2D( 1, 0, 1, 0 ) 
     476            z2d(ji,jj) = (   e2v(ji+1,jj  ) * vv(ji+1,jj  ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm)    & 
     477            &              - e1u(ji  ,jj+1) * uu(ji  ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm)  ) * r1_e1e2f(ji,jj) 
     478         END_2D 
     479         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
     480         CALL iom_put( "relvor", z2d )                  ! relative vorticity ( zeta )  
     481         ! 
     482         CALL iom_put( "plavor", ff_f )                 ! planetary vorticity ( f ) 
     483         ! 
     484         DO_2D( 1, 0, 1, 0 )   
     485            ze3 = (  e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1)    & 
     486              &    + e3t(ji,jj  ,1,Kmm) * e1e2t(ji,jj  ) + e3t(ji+1,jj  ,1,Kmm) * e1e2t(ji+1,jj  )  ) * r1_e1e2f(ji,jj) 
     487            IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
     488            ELSE                      ;   ze3 = 0._wp 
     489            ENDIF 
     490            z2d(ji,jj) = ze3 * z2d(ji,jj)  
     491         END_2D 
     492         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
     493         CALL iom_put( "relpotvor", z2d )                  ! relative potential vorticity (zeta/h) 
     494         ! 
     495         DO_2D( 1, 0, 1, 0 ) 
     496            ze3 = (  e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1)    & 
     497              &    + e3t(ji,jj  ,1,Kmm) * e1e2t(ji,jj  ) + e3t(ji+1,jj  ,1,Kmm) * e1e2t(ji+1,jj  )  ) * r1_e1e2f(ji,jj) 
     498            IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
     499            ELSE                      ;   ze3 = 0._wp 
     500            ENDIF 
     501            z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj)  
     502         END_2D 
     503         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
     504         CALL iom_put( "abspotvor", z2d )                  ! absolute potential vorticity ( q ) 
     505         ! 
     506         DO_2D( 1, 0, 1, 0 )   
     507            z2d(ji,jj) = 0.5_wp * z2d(ji,jj)  * z2d(ji,jj)  
     508         END_2D 
     509         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
     510         CALL iom_put( "Ens", z2d )                        ! potential enstrophy ( 1/2*q2 ) 
     511         ! 
     512      ENDIF 
    426513 
    427514      IF( ln_timing )   CALL timing_stop('dia_wri') 
    … …  
    9971084      !! 
    9981085      INTEGER :: inum, jk 
    999       REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept      ! 3D workspace !!st patch to use substitution 
     1086      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept       ! 3D workspace for qco substitution 
    10001087      !!---------------------------------------------------------------------- 
    10011088      !  
    … …  
    10761163         CALL iom_rstput ( 0, 0, inum, "qz1_abl",  tq_abl(:,:,2,nt_a,2) )   ! now first level humidity 
    10771164      ENDIF 
     1165      IF( ln_zdfosm ) THEN 
     1166         CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1)  )      ! now boundary-layer depth 
     1167         CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1)  )      ! now mixed-layer depth 
     1168         CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask     )      ! w-level diffusion 
     1169         CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask     )      ! now w-level viscosity 
     1170         CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask     )      ! non-local t forcing 
     1171         CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask     )      ! non-local s forcing 
     1172         CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask     )      ! non-local u forcing 
     1173         CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask     )      ! non-local v forcing 
     1174         IF( ln_osm_mle ) THEN 
     1175            CALL iom_rstput( 0, 0, inum, 'hmle', hmle*tmask(:,:,1)  ) ! now transition-layer depth 
     1176         END IF 
     1177      ENDIF 
    10781178      ! 
    10791179      CALL iom_close( inum ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/dom_oce.F90

    r14037 r14062  
    131131   ! 
    132132   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2t , r1_e1e2t                !: associated metrics at t-point 
    133    REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2u , e2_e1u, r1_e1e2u        !: associated metrics at u-point 
    134    REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2v , e1_e2v, r1_e1e2v        !: associated metrics at v-point 
     133   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2u , r1_e1e2u , e2_e1u       !: associated metrics at u-point 
     134   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2v , r1_e1e2v , e1_e2v       !: associated metrics at v-point 
    135135   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2f , r1_e1e2f                !: associated metrics at f-point 
    136136   ! 
    … …  
    162162 
    163163   !                                                        !  reference depths of cells 
    164    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0  !: t- depth              [m] 
    165    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdepw_0  !: w- depth              [m] 
    166    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gde3w_0  !: w- depth (sum of e3w) [m] 
     164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdept_0  !: t- depth              [m] 
     165   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdepw_0  !: w- depth              [m] 
     166   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w_0  !: w- depth (sum of e3w) [m] 
    167167   !                                                        !  time-dependent depths of cells 
    168168   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::  gdept, gdepw   
    … …  
    205205 
    206206   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)           ::   ssmask, ssumask, ssvmask, ssfmask   !: surface mask at T-,U-, V- and F-pts 
    207    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask   !: land/ocean mask at T-, U-, V-, W- and F-pts 
    208    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts 
    209  
     207   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET ::   tmask, umask, vmask, wmask, fmask   !: land/ocean mask at T-, U-, V-, W- and F-pts 
     208   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET ::   wumask, wvmask                      !: land/ocean mask at WU- and WV-pts 
     209#if defined key_qco    
     210   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET ::   fe3mask                             !: land/ocean mask at F-pts for qco 
     211#endif 
    210212   !!---------------------------------------------------------------------- 
    211213   !! calendar variables 
    … …  
    306308         &       e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk)                      ,  STAT=ierr(ii) ) 
    307309         ! 
    308 #if ! defined key_qco 
     310#if defined key_qco 
     311      ii = ii+1 
     312      ALLOCATE( r3t  (jpi,jpj,jpt)   , r3u  (jpi,jpj,jpt)    , r3v  (jpi,jpj,jpt)    , r3f  (jpi,jpj) ,      & 
     313         &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) )              
     314#else 
    309315      ii = ii+1 
    310316      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
    … …  
    313319         ! 
    314320      ii = ii+1 
    315       ALLOCATE( r3t  (jpi,jpj,jpt)   , r3u  (jpi,jpj,jpt)    , r3v  (jpi,jpj,jpt)    , r3f  (jpi,jpj) ,  & 
    316          &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) ) 
    317          ! 
    318       ii = ii+1 
    319321      ALLOCATE( ht_0(jpi,jpj) ,    hu_0(jpi,jpj)    ,    hv_0(jpi,jpj)     , hf_0(jpi,jpj) ,       & 
    320322         &   r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) ,    r1_hv_0(jpi,jpj),   r1_hf_0(jpi,jpj) ,   STAT=ierr(ii)  ) 
    … …  
    323325      ii = ii+1 
    324326      ALLOCATE( ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
    325          &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
    326 #else 
    327       ii = ii+1 
    328       ALLOCATE(                    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
    329327         &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
    330328#endif 
    … …  
    350348      ii = ii+1 
    351349      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
     350#if defined key_qco 
     351         ! 
     352      ii = ii+1 
     353      ALLOCATE( fe3mask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
     354#endif 
    352355      ! 
    353356      dom_oce_alloc = MAXVAL(ierr) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domain.F90

    r14037 r14062  
    1515   !!            3.7  !  2015-11  (G. Madec, A. Coward)  time varying zgr by default 
    1616   !!            4.0  !  2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface 
    17    !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
     17   !!            4.1  !  2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    1818   !!---------------------------------------------------------------------- 
    1919    
    … …  
    2828   USE oce            ! ocean variables 
    2929   USE dom_oce        ! domain: ocean 
     30#if defined key_qco 
     31   USE domqco         ! quasi-eulerian 
     32#else 
     33   USE domvvl         ! variable volume 
     34#endif 
     35   USE sshwzv  , ONLY : ssh_init_rst   ! set initial ssh  
    3036   USE sbc_oce        ! surface boundary condition: ocean 
    3137   USE trc_oce        ! shared ocean & passive tracers variab 
    … …  
    3541   USE dommsk         ! domain: set the mask system 
    3642   USE domwri         ! domain: write the meshmask file 
    37 #if ! defined key_qco 
    38    USE domvvl         ! variable volume 
    39 #else 
    40    USE domqco          ! variable volume 
    41 #endif 
    4243   USE c1d            ! 1D configuration 
    4344   USE dyncor_c1d     ! 1D configuration: Coriolis term    (cor_c1d routine) 
    44    USE wet_dry, ONLY : ll_wd 
    45    USE closea , ONLY : dom_clo ! closed seas 
     45   USE wet_dry , ONLY : ll_wd     ! wet & drying flag 
     46   USE closea  , ONLY : dom_clo   ! closed seas routine 
    4647   ! 
    4748   USE prtctl         ! Print control (prt_ctl_info routine) 
    … …  
    5051   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
    5152   USE lib_mpp        ! distributed memory computing library 
     53   USE restart        ! only for lrst_oce 
    5254 
    5355   IMPLICIT NONE 
    … …  
    5860   PUBLIC   dom_tile     ! called by step.F90 
    5961 
     62   !! * Substitutions 
     63#  include "do_loop_substitute.h90" 
    6064   !!------------------------------------------------------------------------- 
    6165   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8488      INTEGER ::   ji, jj, jk, jt   ! dummy loop indices 
    8589      INTEGER ::   iconf = 0    ! local integers 
     90      REAL(wp)::   zrdt 
    8691      CHARACTER (len=64) ::   cform = "(A12, 3(A13, I7))"  
    8792      INTEGER , DIMENSION(jpi,jpj) ::   ik_top , ik_bot       ! top and bottom ocean level 
    … …  
    121126         WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
    122127      ENDIF 
    123       nn_wxios = 0 
    124       ln_xios_read = .FALSE. 
     128       
    125129      ! 
    126130      !           !==  Reference coordinate system  ==! 
    … …  
    143147      hv_0(:,:) = 0._wp 
    144148      hf_0(:,:) = 0._wp 
    145       DO jk = 1, jpk 
     149      DO jk = 1, jpkm1 
    146150         ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 
    147151         hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 
    148152         hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 
    149          hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk) 
    150153      END DO 
     154      ! 
     155      DO jk = 1, jpkm1 
     156         hf_0(1:jpim1,:) = hf_0(1:jpim1,:) + e3f_0(1:jpim1,:,jk)*vmask(1:jpim1,:,jk)*vmask(2:jpi,:,jk) 
     157      END DO 
     158      CALL lbc_lnk('domain', hf_0, 'F', 1._wp) 
     159      ! 
     160      IF( lk_SWE ) THEN      ! SWE case redefine hf_0 
     161         hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) 
     162      ENDIF 
    151163      ! 
    152164      r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp -  ssmask (:,:) ) 
    … …  
    154166      r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp -  ssvmask(:,:) ) 
    155167      r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp -  ssfmask(:,:) ) 
    156  
     168      ! 
     169      IF( ll_wd ) THEN       ! wet and drying (check ht_0 >= 0) 
     170         DO_2D( 1, 1, 1, 1 ) 
     171            IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN 
     172               CALL ctl_stop( 'ssh_init_rst : ht_0 must be positive at potentially wet points' ) 
     173            ENDIF 
     174         END_2D 
     175      ENDIF 
     176      ! 
     177      !           !==  initialisation of time varying coordinate  ==! 
     178      ! 
     179      !                                 != ssh initialization 
     180      IF( .NOT.l_offline .AND. .NOT.l_SAS ) THEN 
     181         CALL ssh_init_rst( Kbb, Kmm, Kaa ) 
     182      ELSE 
     183         ssh(:,:,:) = 0._wp 
     184      ENDIF 
    157185      ! 
    158186#if defined key_qco 
    159       !           !==  initialisation of time varying coordinate  ==!  Quasi-Euerian coordinate case 
     187      !                                 != Quasi-Euerian coordinate case 
    160188      ! 
    161189      IF( .NOT.l_offline )   CALL dom_qco_init( Kbb, Kmm, Kaa ) 
    162       ! 
    163       IF( ln_linssh )        CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible') 
    164       ! 
    165190#else 
    166       !           !==  time varying part of coordinate system  ==! 
    167       ! 
    168       IF( ln_linssh ) THEN       != Fix in time : set to the reference one for all 
     191      ! 
     192      IF( ln_linssh ) THEN              != Fix in time : set to the reference one for all 
    169193         ! 
    170194         DO jt = 1, jpt                         ! depth of t- and w-grid-points 
    … …  
    175199         ! 
    176200         DO jt = 1, jpt                         ! vertical scale factors 
    177             e3t(:,:,:,jt) =  e3t_0(:,:,:) 
    178             e3u(:,:,:,jt) =  e3u_0(:,:,:) 
    179             e3v(:,:,:,jt) =  e3v_0(:,:,:) 
    180             e3w(:,:,:,jt) =  e3w_0(:,:,:) 
     201            e3t (:,:,:,jt) =  e3t_0(:,:,:) 
     202            e3u (:,:,:,jt) =  e3u_0(:,:,:) 
     203            e3v (:,:,:,jt) =  e3v_0(:,:,:) 
     204            e3w (:,:,:,jt) =  e3w_0(:,:,:) 
    181205            e3uw(:,:,:,jt) = e3uw_0(:,:,:) 
    182206            e3vw(:,:,:,jt) = e3vw_0(:,:,:) 
    183207         END DO 
    184             e3f(:,:,:)    =  e3f_0(:,:,:) 
     208            e3f (:,:,:)    =  e3f_0(:,:,:) 
    185209         ! 
    186210         DO jt = 1, jpt                         ! water column thickness and its inverse 
    187             hu(:,:,jt)    =    hu_0(:,:) 
    188             hv(:,:,jt)    =    hv_0(:,:) 
     211               hu(:,:,jt) =    hu_0(:,:) 
     212               hv(:,:,jt) =    hv_0(:,:) 
    189213            r1_hu(:,:,jt) = r1_hu_0(:,:) 
    190214            r1_hv(:,:,jt) = r1_hv_0(:,:) 
    191215         END DO 
    192             ht(:,:) =    ht_0(:,:) 
    193          ! 
    194       ELSE                       != time varying : initialize before/now/after variables 
     216               ht   (:,:) =    ht_0(:,:) 
     217         ! 
     218      ELSE                              != Time varying : initialize before/now/after variables 
    195219         ! 
    196220         IF( .NOT.l_offline )   CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
    … …  
    373397      USE ioipsl 
    374398      !! 
    375       INTEGER  ::   ios   ! Local integer 
     399      INTEGER ::   ios   ! Local integer 
     400      REAL(wp)::   zrdt 
     401      !!---------------------------------------------------------------------- 
    376402      ! 
    377403      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,                 & 
    … …  
    393419      ENDIF 
    394420      ! 
     421      !                       !=======================! 
     422      !                       !==  namelist namdom  ==! 
     423      !                       !=======================! 
     424      ! 
     425      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
     426903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist' ) 
     427      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 
     428904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 
     429      IF(lwm) WRITE( numond, namdom ) 
     430      ! 
     431#if defined key_agrif 
     432      IF( .NOT. Agrif_Root() ) THEN    ! AGRIF child, subdivide the Parent timestep 
     433         rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() 
     434      ENDIF 
     435#endif 
     436      ! 
     437      IF(lwp) THEN 
     438         WRITE(numout,*) 
     439         WRITE(numout,*) '   Namelist : namdom   ---   space & time domain' 
     440         WRITE(numout,*) '      linear free surface (=T)                ln_linssh   = ', ln_linssh 
     441         WRITE(numout,*) '      create mesh/mask file                   ln_meshmask = ', ln_meshmask 
     442         WRITE(numout,*) '      ocean time step                         rn_Dt       = ', rn_Dt 
     443         WRITE(numout,*) '      asselin time filter parameter           rn_atfp     = ', rn_atfp 
     444         WRITE(numout,*) '      online coarsening of dynamical fields   ln_crs      = ', ln_crs 
     445      ENDIF 
     446      ! 
     447      ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 
     448      rDt   = 2._wp * rn_Dt 
     449      r1_Dt = 1._wp / rDt 
     450      ! 
     451      IF( l_SAS .AND. .NOT.ln_linssh ) THEN 
     452         CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) 
     453         ln_linssh = .TRUE. 
     454      ENDIF 
     455      ! 
     456#if defined key_qco 
     457      IF( ln_linssh )   CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh = T are incompatible' ) 
     458#endif 
     459      ! 
     460      !                       !=======================! 
     461      !                       !==  namelist namrun  ==! 
     462      !                       !=======================! 
    395463      ! 
    396464      READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 
    … …  
    452520      nleapy = nn_leapy 
    453521      ninist = nn_istate 
     522      ! 
     523      !                                        !==  Set parameters for restart reading using xIOS  ==! 
     524      ! 
     525      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
     526         lrxios = ln_xios_read .AND. ln_rstart 
     527         IF( nn_wxios > 0 )   lwxios = .TRUE.           !* set output file type for XIOS based on NEMO namelist 
     528         nxioso = nn_wxios 
     529      ENDIF 
     530      !                                        !==  Check consistency between ln_rstart and ln_1st_euler  ==!   (i.e. set l_1st_euler) 
    454531      l_1st_euler = ln_1st_euler 
    455       IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN 
     532      ! 
     533      IF( ln_rstart ) THEN                              !*  Restart case 
     534         ! 
     535         IF(lwp) WRITE(numout,*) 
     536         IF(lwp) WRITE(numout,*) '   open the restart file' 
     537         CALL rst_read_open                                              !- Open the restart file 
     538         ! 
     539         IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN     !- Check time-step consistency and force Euler restart if changed 
     540            CALL iom_get( numror, 'rdt', zrdt ) 
     541            IF( zrdt /= rn_Dt ) THEN 
     542               IF(lwp) WRITE( numout,*) 
     543               IF(lwp) WRITE( numout,*) '   rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt 
     544               IF(lwp) WRITE( numout,*) 
     545               IF(lwp) WRITE( numout,*) '      ==>>>   forced euler first time-step' 
     546               l_1st_euler =  .TRUE. 
     547            ENDIF 
     548         ENDIF 
     549         ! 
     550         IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN   !- Check absence of one of the Kbb field (here sshb) 
     551            !                                                                             !  (any Kbb field is missing ==> all Kbb fields are missing)  
     552            IF( .NOT.l_1st_euler ) THEN 
     553               CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ',   & 
     554                  &                        'l_1st_euler forced to .true. and ' ,   & 
     555                  &                        'ssh(Kbb) = ssh(Kmm) '                  ) 
     556               l_1st_euler = .TRUE. 
     557            ENDIF 
     558         ENDIF 
     559      ELSEIF( .NOT.l_1st_euler ) THEN                   !*  Initialization case 
    456560         IF(lwp) WRITE(numout,*)   
    457561         IF(lwp) WRITE(numout,*)'   ==>>>   Start from rest (ln_rstart=F)' 
    458562         IF(lwp) WRITE(numout,*)'           an Euler initial time step is used : l_1st_euler is forced to .true. '    
    459          l_1st_euler = .true. 
    460       ENDIF 
    461       !                             ! control of output frequency 
    462       IF( .NOT. ln_rst_list ) THEN     ! we use nn_stock 
     563         l_1st_euler = .TRUE. 
     564      ENDIF 
     565      ! 
     566      !                                        !==  control of output frequency  ==! 
     567      ! 
     568      IF( .NOT. ln_rst_list ) THEN   ! we use nn_stock 
    463569         IF( nn_stock == -1 )   CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 
    464570         IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN 
    … …  
    479585      IF( Agrif_Root() ) THEN 
    480586         IF(lwp) WRITE(numout,*) 
    481          SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     587         SELECT CASE ( nleapy )                !==  Choose calendar for IOIPSL  ==! 
    482588         CASE (  1 )  
    483589            CALL ioconf_calendar('gregorian') 
    … …  
    491597         END SELECT 
    492598      ENDIF 
    493  
    494       READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
    495 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist' ) 
    496       READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 
    497 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 
    498       IF(lwm) WRITE( numond, namdom ) 
    499       ! 
    500 #if defined key_agrif 
    501       IF( .NOT. Agrif_Root() ) THEN 
    502             rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot() 
    503       ENDIF 
    504 #endif 
    505       ! 
    506       IF(lwp) THEN 
    507          WRITE(numout,*) 
    508          WRITE(numout,*) '   Namelist : namdom   ---   space & time domain' 
    509          WRITE(numout,*) '      linear free surface (=T)                ln_linssh   = ', ln_linssh 
    510          WRITE(numout,*) '      create mesh/mask file                   ln_meshmask = ', ln_meshmask 
    511          WRITE(numout,*) '      ocean time step                         rn_Dt       = ', rn_Dt 
    512          WRITE(numout,*) '      asselin time filter parameter           rn_atfp     = ', rn_atfp 
    513          WRITE(numout,*) '      online coarsening of dynamical fields   ln_crs      = ', ln_crs 
    514       ENDIF 
    515       ! 
    516       !! Initialise current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 
    517       rDt  = 2._wp * rn_Dt 
    518       r1_Dt = 1._wp / rDt 
    519  
     599      ! 
     600      !                       !========================! 
     601      !                       !==  namelist namtile  ==! 
     602      !                       !========================! 
     603      ! 
    520604      READ  ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 
    521605905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtile in reference namelist' ) 
    … …  
    537621         ENDIF 
    538622      ENDIF 
    539  
    540       IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    541          lrxios = ln_xios_read.AND.ln_rstart 
    542 !set output file type for XIOS based on NEMO namelist  
    543          IF (nn_wxios > 0) lwxios = .TRUE.  
    544          nxioso = nn_wxios 
    545       ENDIF 
    546  
     623      ! 
    547624#if defined key_netcdf4 
    548       !                             ! NetCDF 4 case   ("key_netcdf4" defined) 
     625      !                       !=======================! 
     626      !                       !==  namelist namnc4  ==!   NetCDF 4 case   ("key_netcdf4" defined) 
     627      !                       !=======================! 
     628      ! 
    549629      READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 
    550630907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) 
    … …  
    555635      IF(lwp) THEN                        ! control print 
    556636         WRITE(numout,*) 
    557          WRITE(numout,*) '   Namelist namnc4 - Netcdf4 chunking parameters' 
     637         WRITE(numout,*) '   Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' 
    558638         WRITE(numout,*) '      number of chunks in i-dimension             nn_nchunks_i = ', nn_nchunks_i 
    559639         WRITE(numout,*) '      number of chunks in j-dimension             nn_nchunks_j = ', nn_nchunks_j 
    … …  
    618698   SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
    619699      !!---------------------------------------------------------------------- 
    620       !!                     ***  ROUTINE dom_nam  *** 
     700      !!                     ***  ROUTINE domain_cfg  *** 
    621701      !!                     
    622702      !! ** Purpose :   read the domain size in domain configuration file 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/dommsk.F90

    r14037 r14062  
    181181      ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 
    182182      ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 
     183      IF( lk_SWE ) THEN      ! Shallow Water Eq. case : redefine ssfmask 
     184         DO_2D( 0,0 , 0,0 ) 
     185            ssfmask(ji,jj) = MAX(  ssmask(ji,jj+1), ssmask(ji+1,jj+1),  &  
     186               &                   ssmask(ji,jj  ), ssmask(ji+1,jj  )   ) 
     187         END_2D 
     188         CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) 
     189      ENDIF 
     190#if defined key_qco 
     191      fe3mask(:,:,:) = fmask(:,:,:) 
     192#endif 
    183193 
    184194      ! Interior domain mask  (used for global sum) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domqco.F90

    r14037 r14062  
    88   !!            3.3  !  2011-10  (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates 
    99   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    10    !!            4.1  !  2019-08  (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 
    11    !!            4.x  !  2020-02  (G. Madec, S. Techene) pure z* (quasi-eulerian) coordinate 
    12    !!---------------------------------------------------------------------- 
    13  
    14    !!---------------------------------------------------------------------- 
    15    !!   dom_qe_init   : define initial vertical scale factors, depths and column thickness 
    16    !!   dom_qe_r3c    : Compute ssh/h_0 ratioat t-, u-, v-, and optionally f-points 
    17    !!       qe_rst_read : read/write restart file 
    18    !!   dom_qe_ctl    : Check the vvl options 
     10   !!            4.1  !  2019-08  (A. Coward, D. Storkey) add time level indices for prognostic variables 
     11   !!             -   !  2020-02  (S. Techene, G. Madec) quasi-eulerian coordinate (z* or s*) 
     12   !!---------------------------------------------------------------------- 
     13 
     14   !!---------------------------------------------------------------------- 
     15   !!   dom_qco_init  : define initial vertical scale factors, depths and column thickness 
     16   !!   dom_qco_zgr   : Set ssh/h_0 ratio at t 
     17   !!   dom_qco_r3c   : Compute ssh/h_0 ratio at t-, u-, v-, and optionally f-points 
     18   !!       qco_ctl   : Check the vvl options 
    1919   !!---------------------------------------------------------------------- 
    2020   USE oce            ! ocean dynamics and tracers 
    … …  
    5555   LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE.                ! debug control prints 
    5656 
    57    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td                ! thickness diffusion transport 
    58  
    5957   !! * Substitutions 
    6058#  include "do_loop_substitute.h90" 
    … …  
    7977      !! 
    8078      !!---------------------------------------------------------------------- 
    81       INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 
     79      INTEGER, INTENT(in) ::   Kbb, Kmm, Kaa   ! time level indices 
     80      !!---------------------------------------------------------------------- 
    8281      ! 
    8382      IF(lwp) WRITE(numout,*) 
    … …  
    8584      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    8685      ! 
    87       CALL dom_qco_ctl     ! choose vertical coordinate (z_star, z_tilde or layer) 
    88       ! 
    89       !                    ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf 
    90       CALL qe_rst_read( nit000, Kbb, Kmm ) 
    91       ! 
    92       CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 
     86      CALL qco_ctl                            ! choose vertical coordinate (z_star, z_tilde or layer) 
     87      ! 
     88      CALL dom_qco_zgr( Kbb, Kmm )            ! interpolation scale factor, depth and water column 
     89      ! 
     90#if defined key_agrif 
     91      ! We need to define r3[tuv](Kaa) for AGRIF initialisation (should not be a 
     92      ! problem for the restartability...) 
     93      r3t(:,:,Kaa) = r3t(:,:,Kmm) 
     94      r3u(:,:,Kaa) = r3u(:,:,Kmm) 
     95      r3v(:,:,Kaa) = r3v(:,:,Kmm) 
     96#endif 
    9397      ! 
    9498   END SUBROUTINE dom_qco_init 
    9599 
    96100 
    97    SUBROUTINE dom_qco_zgr(Kbb, Kmm, Kaa) 
     101   SUBROUTINE dom_qco_zgr( Kbb, Kmm ) 
    98102      !!---------------------------------------------------------------------- 
    99103      !!                ***  ROUTINE dom_qco_init  *** 
    100104      !! 
    101       !! ** Purpose :  Initialization of all ssh. to h._0 ratio 
    102       !! 
    103       !! ** Method  :  - interpolate scale factors 
    104       !! 
    105       !! ** Action  : - r3(t/u/v)_b 
    106       !!              - r3(t/u/v/f)_n 
    107       !! 
    108       !! Reference  : Leclair, M., and G. Madec, 2011, Ocean Modelling. 
    109       !!---------------------------------------------------------------------- 
    110       INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 
     105      !! ** Purpose :  Initialization of all r3. = ssh./h._0 ratios 
     106      !! 
     107      !! ** Method  :  Call domqco using Kbb and Kmm 
     108      !!               NB: dom_qco_zgr is called by dom_qco_init it uses ssh from ssh_init  
     109      !! 
     110      !! ** Action  : - r3(t/u/v)(Kbb) 
     111      !!              - r3(t/u/v/f)(Kmm) 
     112      !!---------------------------------------------------------------------- 
     113      INTEGER, INTENT(in) ::   Kbb, Kmm   ! time level indices 
    111114      !!---------------------------------------------------------------------- 
    112115      ! 
    113116      !                    !== Set of all other vertical scale factors  ==!  (now and before) 
    114117      !                                ! Horizontal interpolation of e3t 
    115       CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 
     118      CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb)           ) 
    116119      CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) 
    117120      ! 
    … …  
    143146      !                                      !==  ratio at u-,v-point  ==! 
    144147      ! 
    145       IF( ln_dynadv_vec ) THEN                     !- Vector Form   (thickness weighted averaging) 
     148!!st      IF( ln_dynadv_vec ) THEN                     !- Vector Form   (thickness weighted averaging) 
     149#if ! defined key_qcoTest_FluxForm 
     150      !                                ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 
    146151         DO_2D( 0, 0, 0, 0 ) 
    147152            pr3u(ji,jj) = 0.5_wp * (  e1e2t(ji  ,jj) * pssh(ji  ,jj)  & 
    … …  
    150155               &                    + e1e2t(ji,jj+1) * pssh(ji,jj+1)  ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) 
    151156         END_2D 
    152       ELSE                                         !- Flux Form   (simple averaging) 
     157!!st      ELSE                                         !- Flux Form   (simple averaging) 
     158#else 
    153159         DO_2D( 0, 0, 0, 0 ) 
    154             pr3u(ji,jj) = 0.5_wp * (  pssh(ji  ,jj) + pssh(ji+1,jj)  ) * r1_hu_0(ji,jj) 
    155             pr3v(ji,jj) = 0.5_wp * (  pssh(ji,jj  ) + pssh(ji,jj+1)  ) * r1_hv_0(ji,jj) 
     160            pr3u(ji,jj) = 0.5_wp * (  pssh(ji,jj) + pssh(ji+1,jj  )  ) * r1_hu_0(ji,jj) 
     161            pr3v(ji,jj) = 0.5_wp * (  pssh(ji,jj) + pssh(ji  ,jj+1)  ) * r1_hv_0(ji,jj) 
    156162         END_2D 
    157       ENDIF 
     163!!st      ENDIF 
     164#endif          
    158165      ! 
    159166      IF( .NOT.PRESENT( pr3f ) ) THEN              !- lbc on ratio at u-, v-points only 
    … …  
    163170      ELSE                                   !==  ratio at f-point  ==! 
    164171         ! 
    165          IF( ln_dynadv_vec )   THEN                !- Vector Form   (thickness weighted averaging) 
    166             DO_2D( 1, 0, 1, 0 )                               ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 
     172!!st         IF( ln_dynadv_vec )   THEN                !- Vector Form   (thickness weighted averaging) 
     173#if ! defined key_qcoTest_FluxForm 
     174         !                                ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 
     175 
     176            DO_2D( 0, 0, 0, 0 )                               ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 
    167177               pr3f(ji,jj) = 0.25_wp * (  e1e2t(ji  ,jj  ) * pssh(ji  ,jj  )  & 
    168178                  &                     + e1e2t(ji+1,jj  ) * pssh(ji+1,jj  )  & 
    … …  
    170180                  &                     + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1)  ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 
    171181            END_2D 
    172          ELSE                                      !- Flux Form   (simple averaging) 
    173             DO_2D( 1, 0, 1, 0 )                               ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 
    174                pr3f(ji,jj) = 0.25_wp * (  pssh(ji  ,jj  ) + pssh(ji+1,jj  )  & 
    175                   &                     + pssh(ji  ,jj+1) + pssh(ji+1,jj+1)  ) * r1_hf_0(ji,jj) 
     182!!st         ELSE                                      !- Flux Form   (simple averaging) 
     183#else 
     184            DO_2D( 0, 0, 0, 0 )                               ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 
     185               pr3f(ji,jj) = 0.25_wp * (  pssh(ji,jj  ) + pssh(ji+1,jj  )  & 
     186                  &                     + pssh(ji,jj+1) + pssh(ji+1,jj+1)  ) * r1_hf_0(ji,jj) 
    176187            END_2D 
    177          ENDIF 
     188!!st         ENDIF 
     189#endif 
    178190         !                                                 ! lbc on ratio at u-,v-,f-points 
    179191         CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) 
    … …  
    184196 
    185197 
    186    SUBROUTINE qe_rst_read( kt, Kbb, Kmm ) 
     198   SUBROUTINE qco_ctl 
    187199      !!--------------------------------------------------------------------- 
    188       !!                   ***  ROUTINE qe_rst_read  *** 
    189       !! 
    190       !! ** Purpose :   Read ssh in restart file 
    191       !! 
    192       !! ** Method  :   use of IOM library 
    193       !!                if the restart does not contain ssh, 
    194       !!                it is set to the _0 values. 
    195       !!---------------------------------------------------------------------- 
    196       INTEGER         , INTENT(in) ::   kt        ! ocean time-step 
    197       INTEGER         , INTENT(in) ::   Kbb, Kmm  ! ocean time level indices 
    198       ! 
    199       INTEGER ::   ji, jj, jk 
    200       INTEGER ::   id1, id2     ! local integers 
    201       !!---------------------------------------------------------------------- 
    202       ! 
    203          IF( ln_rstart ) THEN                   !* Read the restart file 
    204             CALL rst_read_open                  !  open the restart file if necessary 
    205             ! 
    206             id1 = iom_varid( numror, 'sshb', ldstop = .FALSE. ) 
    207             id2 = iom_varid( numror, 'sshn', ldstop = .FALSE. ) 
    208             ! 
    209             !                             ! --------- ! 
    210             !                             ! all cases ! 
    211             !                             ! --------- ! 
    212             ! 
    213             IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
    214                CALL iom_get( numror, jpdom_auto, 'sshb'   , ssh(:,:,Kbb)    ) 
    215                CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm)    ) 
    216                ! needed to restart if land processor not computed 
    217                IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' 
    218                WHERE ( ssmask(:,:) == 0.0_wp )   !!gm/st ==> sm should not be necessary on ssh when it was required on e3 
    219                   ssh(:,:,Kmm) = 0._wp 
    220                   ssh(:,:,Kbb) = 0._wp 
    221                END WHERE 
    222                IF( l_1st_euler ) THEN 
    223                   ssh(:,:,Kbb) = ssh(:,:,Kmm) 
    224                ENDIF 
    225             ELSE IF( id1 > 0 ) THEN 
    226                IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart files' 
    227                IF(lwp) write(numout,*) 'sshn set equal to sshb.' 
    228                IF(lwp) write(numout,*) 'neuler is forced to 0' 
    229                CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 
    230                ssh(:,:,Kmm) = ssh(:,:,Kbb) 
    231                l_1st_euler = .TRUE. 
    232             ELSE IF( id2 > 0 ) THEN 
    233                IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kbb) not found in restart files' 
    234                IF(lwp) write(numout,*) 'sshb set equal to sshn.' 
    235                IF(lwp) write(numout,*) 'neuler is forced to 0' 
    236                CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 
    237                ssh(:,:,Kbb) = ssh(:,:,Kmm) 
    238                l_1st_euler = .TRUE. 
    239             ELSE 
    240                IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart file' 
    241                IF(lwp) write(numout,*) 'ssh_b and ssh_n set to zero' 
    242                IF(lwp) write(numout,*) 'neuler is forced to 0' 
    243                ssh(:,:,:) = 0._wp 
    244                l_1st_euler = .TRUE. 
    245             ENDIF 
    246             ! 
    247          ELSE                                   !* Initialize at "rest" 
    248             ! 
    249             IF( ll_wd ) THEN   ! MJB ll_wd edits start here - these are essential 
    250                ! 
    251                IF( cn_cfg == 'wad' ) THEN            ! Wetting and drying test case 
    252                   CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  ) 
    253                   ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    254                   ssh(:,:    ,Kmm) = ssh(:,:    ,Kbb) 
    255                   uu (:,:,:  ,Kmm) = uu (:,:,:  ,Kbb) 
    256                   vv (:,:,:  ,Kmm) = vv (:,:,:  ,Kbb) 
    257                ELSE                                  ! if not test case 
    258                   ssh(:,:,Kmm) = -ssh_ref 
    259                   ssh(:,:,Kbb) = -ssh_ref 
    260                   ! 
    261                   DO_2D( 1, 1, 1, 1 ) 
    262                      IF( ht_0(ji,jj)-ssh_ref <  rn_wdmin1 ) THEN ! if total depth is less than min depth 
    263                         ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 
    264                         ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 
    265                      ENDIF 
    266                   END_2D 
    267                ENDIF 
    268  
    269                DO ji = 1, jpi 
    270                   DO jj = 1, jpj 
    271                      IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 
    272                        CALL ctl_stop( 'qe_rst_read: ht_0 must be positive at potentially wet points' ) 
    273                      ENDIF 
    274                   END DO 
    275                END DO 
    276                ! 
    277             ELSE 
    278                ! 
    279                ! Just to read set ssh in fact, called latter once vertical grid 
    280                ! is set up: 
    281 !               CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  ) 
    282 !               ! 
    283                 ssh(:,:,:) = 0._wp 
    284                ! 
    285             ENDIF           ! end of ll_wd edits 
    286             ! 
    287          ENDIF 
    288       ! 
    289    END SUBROUTINE qe_rst_read 
    290  
    291  
    292    SUBROUTINE dom_qco_ctl 
    293       !!--------------------------------------------------------------------- 
    294       !!                  ***  ROUTINE dom_qco_ctl  *** 
     200      !!                  ***  ROUTINE qco_ctl  *** 
    295201      !! 
    296202      !! ** Purpose :   Control the consistency between namelist options 
    … …  
    312218      IF(lwp) THEN                    ! Namelist print 
    313219         WRITE(numout,*) 
    314          WRITE(numout,*) 'dom_qco_ctl : choice/control of the variable vertical coordinate' 
    315          WRITE(numout,*) '~~~~~~~~~~~' 
     220         WRITE(numout,*) 'qco_ctl : choice/control of the variable vertical coordinate' 
     221         WRITE(numout,*) '~~~~~~~~' 
    316222         WRITE(numout,*) '   Namelist nam_vvl : chose a vertical coordinate' 
    317223         WRITE(numout,*) '      zstar                      ln_vvl_zstar   = ', ln_vvl_zstar 
    … …  
    357263#endif 
    358264      ! 
    359    END SUBROUTINE dom_qco_ctl 
     265   END SUBROUTINE qco_ctl 
    360266 
    361267   !!====================================================================== 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domvvl.F90

    r14037 r14062  
    99   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    1010   !!            4.1  !  2019-08  (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 
    11    !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
     11   !!             -   ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    1212   !!---------------------------------------------------------------------- 
    1313 
    … …  
    766766      !! ** Purpose :   Read or write VVL file in restart file 
    767767      !! 
    768       !! ** Method  :   use of IOM library 
    769       !!                if the restart does not contain vertical scale factors, 
    770       !!                they are set to the _0 values 
    771       !!                if the restart does not contain vertical scale factors increments (z_tilde), 
    772       !!                they are set to 0. 
     768      !! ** Method  : * restart comes from a linear ssh simulation : 
     769      !!                   an attempt to read e3t_n stops simulation 
     770      !!              * restart comes from a z-star, z-tilde, or layer : 
     771      !!                   read e3t_n and e3t_b 
     772      !!              * restart comes from a z-star : 
     773      !!                   set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0 
     774      !!              * restart comes from layer : 
     775      !!                   read tilde_e3t_n and tilde_e3t_b 
     776      !!                   set hdiv_lf to 0 
     777      !!              * restart comes from a z-tilde: 
     778      !!                   read tilde_e3t_n, tilde_e3t_b, and hdiv_lf 
     779      !! 
     780      !!              NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found) 
     781      !!                   Kbb fields set to Kmm ones 
    773782      !!---------------------------------------------------------------------- 
    774783      INTEGER         , INTENT(in) ::   kt        ! ocean time-step 
    … …  
    776785      CHARACTER(len=*), INTENT(in) ::   cdrw      ! "READ"/"WRITE" flag 
    777786      ! 
    778       INTEGER ::   ji, jj, jk 
    779       INTEGER ::   id1, id2, id3, id4, id5     ! local integers 
    780       !!---------------------------------------------------------------------- 
    781       ! 
    782       IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    783          !                                   ! =============== 
    784          IF( ln_rstart ) THEN                   !* Read the restart file 
    785             CALL rst_read_open                  !  open the restart file if necessary 
    786             CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm)    ) 
     787      INTEGER ::   ji, jj, jk      ! dummy loop indices 
     788      INTEGER ::   id3, id4, id5   ! local integers 
     789      !!---------------------------------------------------------------------- 
     790      ! 
     791      !                                      !=====================! 
     792      IF( TRIM(cdrw) == 'READ' ) THEN        !  Read / initialise  ! 
     793         !                                   !=====================! 
     794         ! 
     795         IF( ln_rstart ) THEN                   !==  Read the restart file  ==! 
    787796            ! 
    788             id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    789             id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. ) 
    790             id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 
     797            CALL rst_read_open                                          !*  open the restart file if necessary 
     798            !                                         ! --------- ! 
     799            !                                         ! all cases ! 
     800            !                                         ! --------- ! 
     801            ! 
     802            id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. )  !*  check presence 
    791803            id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 
    792             id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. ) 
     804            id5 = iom_varid( numror, 'hdiv_lf'    , ldstop = .FALSE. ) 
    793805            ! 
    794             !                             ! --------- ! 
    795             !                             ! all cases ! 
    796             !                             ! --------- ! 
    797             ! 
    798             IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
     806            !                                                           !*  scale factors 
     807            IF(lwp) WRITE(numout,*)    '          Kmm scale factor read in the restart file' 
     808            CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
     809            WHERE ( tmask(:,:,:) == 0.0_wp )  
     810               e3t(:,:,:,Kmm) = e3t_0(:,:,:) 
     811            END WHERE 
     812            IF( l_1st_euler ) THEN                       ! euler 
     813               IF(lwp) WRITE(numout,*) '          Euler first time step : e3t(Kbb) = e3t(Kmm)' 
     814               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
     815            ELSE                                         ! leap frog 
     816               IF(lwp) WRITE(numout,*) '          Kbb scale factor read in the restart file' 
    799817               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 
    800                CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
    801                ! needed to restart if land processor not computed  
    802                IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    803818               WHERE ( tmask(:,:,:) == 0.0_wp )  
    804                   e3t(:,:,:,Kmm) = e3t_0(:,:,:) 
    805819                  e3t(:,:,:,Kbb) = e3t_0(:,:,:) 
    806820               END WHERE 
    807                IF( l_1st_euler ) THEN 
    808                   e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    809                ENDIF 
    810             ELSE IF( id1 > 0 ) THEN 
    811                IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files' 
    812                IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    813                IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    814                CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 
    815                e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    816                l_1st_euler = .true. 
    817             ELSE IF( id2 > 0 ) THEN 
    818                IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files' 
    819                IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    820                IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    821                CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
    822                e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    823                l_1st_euler = .true. 
    824             ELSE 
    825                IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file' 
    826                IF(lwp) write(numout,*) 'Compute scale factor from sshn' 
    827                IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    828                DO jk = 1, jpk 
    829                   e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 
    830                       &                          / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   & 
    831                       &          + e3t_0(:,:,jk)                               * (1._wp -tmask(:,:,jk)) 
    832                END DO 
    833                e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    834                l_1st_euler = .true. 
    835821            ENDIF 
    836             !                             ! ----------- ! 
    837             IF( ln_vvl_zstar ) THEN       ! z_star case ! 
    838                !                          ! ----------- ! 
     822            !                                         ! ------------ ! 
     823            IF( ln_vvl_zstar ) THEN                   ! z_star case ! 
     824               !                                      ! ------------ ! 
    839825               IF( MIN( id3, id4 ) > 0 ) THEN 
    840826                  CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 
    841827               ENDIF 
    842                !                          ! ----------------------- ! 
    843             ELSE                          ! z_tilde and layer cases ! 
    844                !                          ! ----------------------- ! 
    845                IF( MIN( id3, id4 ) > 0 ) THEN  ! all required arrays exist 
    846                   CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
     828               !                                      ! ------------------------ ! 
     829            ELSE                                      !  z_tilde and layer cases ! 
     830               !                                      ! ------------------------ ! 
     831               ! 
     832               IF( id4 > 0 ) THEN                                       !*  scale factor increments 
     833                  IF(lwp) WRITE(numout,*)    '          Kmm scale factor increments read in the restart file' 
    847834                  CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 
    848                ELSE                            ! one at least array is missing 
     835                  IF( l_1st_euler ) THEN                 ! euler 
     836                     IF(lwp) WRITE(numout,*) '          Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)' 
     837                     tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 
     838                  ELSE                                   ! leap frog 
     839                     IF(lwp) WRITE(numout,*) '          Kbb scale factor increments read in the restart file' 
     840                     CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
     841                  ENDIF 
     842               ELSE  
    849843                  tilde_e3t_b(:,:,:) = 0.0_wp 
    850844                  tilde_e3t_n(:,:,:) = 0.0_wp 
    851845               ENDIF 
    852                !                          ! ------------ ! 
    853                IF( ln_vvl_ztilde ) THEN   ! z_tilde case ! 
    854                   !                       ! ------------ ! 
     846               !                                      ! ------------ ! 
     847               IF( ln_vvl_ztilde ) THEN               ! z_tilde case ! 
     848                  !                                   ! ------------ ! 
    855849                  IF( id5 > 0 ) THEN  ! required array exists 
    856850                     CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 
    857851                  ELSE                ! array is missing 
    858                      hdiv_lf(:,:,:) = 0.0_wp 
     852                     hdiv_lf(:,:,:) = 0.0_wp  
    859853                  ENDIF 
    860854               ENDIF 
    861855            ENDIF 
    862856            ! 
    863          ELSE                                   !* Initialize at "rest" 
     857         ELSE                                   !==  Initialize at "rest" with ssh  ==! 
    864858            ! 
    865  
    866             IF( ll_wd ) THEN   ! MJB ll_wd edits start here - these are essential  
    867                ! 
    868                IF( cn_cfg == 'wad' ) THEN 
    869                   ! Wetting and drying test case 
    870                   CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  ) 
    871                   ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    872                   ssh (:,:,Kmm)     = ssh(:,:,Kbb) 
    873                   uu   (:,:,:,Kmm)   = uu  (:,:,:,Kbb) 
    874                   vv   (:,:,:,Kmm)   = vv  (:,:,:,Kbb) 
    875                ELSE 
    876                   ! if not test case 
    877                   ssh(:,:,Kmm) = -ssh_ref 
    878                   ssh(:,:,Kbb) = -ssh_ref 
    879  
    880                   DO_2D( 1, 1, 1, 1 ) 
    881                      IF( ht_0(ji,jj)-ssh_ref <  rn_wdmin1 ) THEN ! if total depth is less than min depth 
    882                         ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 
    883                         ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 
    884                      ENDIF 
    885                   END_2D 
    886                ENDIF !If test case else 
    887  
    888                ! Adjust vertical metrics for all wad 
    889                DO jk = 1, jpk 
    890                   e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm)  ) & 
    891                     &                            / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   & 
    892                     &            + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 
    893                END DO 
    894                e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    895  
    896                DO_2D( 1, 1, 1, 1 ) 
    897                   IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 
    898                      CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 
    899                   ENDIF 
    900                END_2D 
    901                ! 
    902             ELSE 
    903                ! 
    904                ! Just to read set ssh in fact, called latter once vertical grid 
    905                ! is set up: 
    906 !               CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  ) 
    907 !               ! 
    908 !               DO jk=1,jpk 
    909 !                  e3t(:,:,jk,Kbb) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 
    910 !                     &            / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk) 
    911 !               END DO 
    912 !               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    913                 ssh(:,:,Kmm)=0._wp 
    914                 e3t(:,:,:,Kmm)=e3t_0(:,:,:) 
    915                 e3t(:,:,:,Kbb)=e3t_0(:,:,:) 
    916                ! 
    917             END IF           ! end of ll_wd edits 
    918  
     859            DO jk = 1, jpk 
     860               e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 
     861            END DO 
     862            e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
     863            ! 
    919864            IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 
    920865               tilde_e3t_b(:,:,:) = 0._wp 
    921866               tilde_e3t_n(:,:,:) = 0._wp 
    922867               IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp 
    923             END IF 
     868            ENDIF 
    924869         ENDIF 
    925          ! 
    926       ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file 
    927          !                                   ! =================== 
     870         !                                       !=======================! 
     871      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN       !  Create restart file  ! 
     872         !                                       !=======================! 
     873         ! 
    928874         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    929875         !                                           ! --------- ! 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domzgr_substitute.h90

    r13237 r14062  
    1515#   define  e3u(i,j,k,t)   (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k))) 
    1616#   define  e3v(i,j,k,t)   (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k))) 
    17 #   define  e3f(i,j,k)     (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fmask(i,j,k))) 
     17#   define  e3f(i,j,k)     (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 
     18#   define  e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 
    1819#   define  e3w(i,j,k,t)   (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 
    1920#   define  e3uw(i,j,k,t)  (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) 
    2021#   define  e3vw(i,j,k,t)  (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t))) 
    21 #   define  ht(i,j)        (ht_0(i,j)+ssh(i,j,Kmm)) 
     22#   define  ht(i,j)        (ht_0(i,j)*(1._wp+r3t(i,j,Kmm))) 
    2223#   define  hu(i,j,t)      (hu_0(i,j)*(1._wp+r3u(i,j,t))) 
    2324#   define  hv(i,j,t)      (hv_0(i,j)*(1._wp+r3v(i,j,t))) 
    … …  
    2930#endif 
    3031!!---------------------------------------------------------------------- 
     32!!#   define  e3t_f(i,j,k)   (e3t_0(i,j,k)*(1._wp+r3t_f(i,j)*tmask(i,j,k))) 
     33!!#   define  e3u_f(i,j,k)   (e3u_0(i,j,k)*(1._wp+r3u_f(i,j)*umask(i,j,k))) 
     34!!#   define  e3v_f(i,j,k)   (e3v_0(i,j,k)*(1._wp+r3v_f(i,j)*vmask(i,j,k))) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/istate.F90

    r13295 r14062  
    4242   PRIVATE 
    4343 
    44    PUBLIC   istate_init   ! routine called by step.F90 
     44   PUBLIC   istate_init   ! routine called by nemogcm.F90 
    4545 
    4646   !! * Substitutions 
    … …  
    5959      !!  
    6060      !! ** Purpose :   Initialization of the dynamics and tracer fields. 
     61      !! 
     62      !! ** Method  :    
    6163      !!---------------------------------------------------------------------- 
    6264      INTEGER, INTENT( in )  ::  Kbb, Kmm, Kaa   ! ocean time level indices 
    6365      ! 
    6466      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    65       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zgdept     ! 3D table  !!st patch to use gdept subtitute 
     67      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zgdept     ! 3D table for qco substitute 
    6668!!gm see comment further down 
    6769      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   zuvd    ! U & V data workspace 
    … …  
    7375      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    7476 
    75 !!gm  Why not include in the first call of dta_tsd ?   
    76 !!gm  probably associated with the use of internal damping... 
    7777       CALL dta_tsd_init        ! Initialisation of T & S input data 
    78 !!gm to be moved in usrdef of C1D case 
     78 
    7979!      IF( lk_c1d )   CALL dta_uvd_init        ! Initialization of U & V input data 
    80 !!gm 
    8180 
    82       rhd  (:,:,:  ) = 0._wp   ;   rhop (:,:,:  ) = 0._wp      ! set one for all to 0 at level jpk 
    83       rn2b (:,:,:  ) = 0._wp   ;   rn2  (:,:,:  ) = 0._wp      ! set one for all to 0 at levels 1 and jpk 
    84       ts  (:,:,:,:,Kaa) = 0._wp                                   ! set one for all to 0 at level jpk 
    85       rab_b(:,:,:,:) = 0._wp   ;   rab_n(:,:,:,:) = 0._wp      ! set one for all to 0 at level jpk 
     81      rhd  (:,:,:      ) = 0._wp   ;   rhop (:,:,:  ) = 0._wp      ! set one for all to 0 at level jpk 
     82      rn2b (:,:,:      ) = 0._wp   ;   rn2  (:,:,:  ) = 0._wp      ! set one for all to 0 at levels 1 and jpk 
     83      ts   (:,:,:,:,Kaa) = 0._wp                                   ! set one for all to 0 at level jpk 
     84      rab_b(:,:,:,:    ) = 0._wp   ;   rab_n(:,:,:,:) = 0._wp      ! set one for all to 0 at level jpk 
    8685#if defined key_agrif 
    8786      uu   (:,:,:  ,Kaa) = 0._wp   ! used in agrif_oce_sponge at initialization 
    … …  
    9695         CALL agrif_istate( Kbb, Kmm, Kaa )   ! Interp from parent 
    9796         ! 
    98          ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)  
    99          ssh (:,:,Kmm)     = ssh(:,:,Kbb) 
    100          uu   (:,:,:,Kmm)   = uu  (:,:,:,Kbb) 
    101          vv   (:,:,:,Kmm)   = vv  (:,:,:,Kbb) 
     97         ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 
     98!!st 
     99!!st need for a recent agrif version to be displaced toward ssh_init_rst with agrif_istate_ssh 
     100         ssh(:,:,    Kmm) = ssh(:,:    ,Kbb) 
     101!!st end 
     102         uu (:,:,:  ,Kmm) = uu (:,:,:  ,Kbb) 
     103         vv (:,:,:  ,Kmm) = vv (:,:,:  ,Kbb) 
    102104      ELSE 
    103105#endif 
    … …  
    117119            CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) )       ! read 3D T and S data at nit000 
    118120            ! 
    119             ssh(:,:,Kbb)   = 0._wp               ! set the ocean at rest 
    120             uu  (:,:,:,Kbb) = 0._wp 
    121             vv  (:,:,:,Kbb) = 0._wp   
     121            uu (:,:,:,Kbb) = 0._wp 
     122            vv (:,:,:,Kbb) = 0._wp   
    122123            ! 
    123             IF( ll_wd ) THEN 
    124                ssh(:,:,Kbb) =  -ssh_ref  ! Added in 30 here for bathy that adds 30 as Iterative test CEOD  
    125                ! 
    126                ! Apply minimum wetdepth criterion 
    127                ! 
    128                DO_2D( 1, 1, 1, 1 ) 
    129                   IF( ht_0(ji,jj) + ssh(ji,jj,Kbb)  < rn_wdmin1 ) THEN 
    130                      ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) 
    131                   ENDIF 
    132                END_2D 
    133             ENDIF  
    134              ! 
    135124         ELSE                                 ! user defined initial T and S 
    136125            DO jk = 1, jpk 
    137126               zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 
    138127            END DO 
    139             CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  )          
     128            CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 
    140129         ENDIF 
    141          ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    142          ssh (:,:,Kmm)     = ssh(:,:,Kbb)    
    143          uu   (:,:,:,Kmm)   = uu  (:,:,:,Kbb) 
    144          vv   (:,:,:,Kmm)   = vv  (:,:,:,Kbb) 
    145  
    146 !!gm POTENTIAL BUG : 
    147 !!gm  ISSUE :  if ssh(:,:,Kbb) /= 0  then, in non linear free surface, the e3._n, e3._b should be recomputed 
    148 !!             as well as gdept_ and gdepw_....   !!!!!  
    149 !!      ===>>>>   probably a call to domvvl initialisation here.... 
    150  
     130         ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
     131         uu (:,:,:  ,Kmm) = uu (:,:,:  ,Kbb) 
     132         vv (:,:,:  ,Kmm) = vv (:,:,:  ,Kbb) 
    151133 
    152134         ! 
    153 !!gm to be moved in usrdef of C1D case 
    154 !         IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 
    155 !            ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 
    156 !            CALL dta_uvd( nit000, zuvd ) 
    157 !            uu(:,:,:,Kbb) = zuvd(:,:,:,1) ;  uu(:,:,:,Kmm) = uu(:,:,:,Kbb) 
    158 !            vv(:,:,:,Kbb) = zuvd(:,:,:,2) ;  vv(:,:,:,Kmm) = vv(:,:,:,Kbb) 
    159 !            DEALLOCATE( zuvd ) 
    160 !         ENDIF 
     135!!gm ==>>>  to be moved in usrdef_istate of C1D case  
     136         IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 
     137            ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 
     138            CALL dta_uvd( nit000, Kbb, zuvd ) 
     139            uu(:,:,:,Kbb) = zuvd(:,:,:,1) ;  uu(:,:,:,Kmm) = uu(:,:,:,Kbb) 
     140            vv(:,:,:,Kbb) = zuvd(:,:,:,2) ;  vv(:,:,:,Kmm) = vv(:,:,:,Kbb) 
     141            DEALLOCATE( zuvd ) 
     142         ENDIF 
    161143         ! 
    162 !!gm This is to be changed !!!! 
    163 !         ! - ML - ssh(:,:,Kmm) could be modified by istate_eel, so that initialization of e3t(:,:,:,Kbb) is done here 
    164 !         IF( .NOT.ln_linssh ) THEN 
    165 !            DO jk = 1, jpk 
    166 !               e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
    167 !            END DO 
    168 !         ENDIF 
    169 !!gm  
    170144         !  
    171145      ENDIF  

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/phycst.F90

    r12489 r14062  
    6666   REAL(wp), PUBLIC ::   r1_rhos                     !: 1 / rhos 
    6767   REAL(wp), PUBLIC ::   r1_rcpi                     !: 1 / rcpi 
     68    
    6869   !!---------------------------------------------------------------------- 
    6970   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynadv.F90

    r12377 r14062  
    127127      IF( ioptio /= 1 )   CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) 
    128128      IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW )   CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 
    129  
     129#if defined key_qcoTest_FluxForm 
     130      IF( ln_dynadv_vec  ) THEN CALL ctl_stop( 'STOP', 'key_qcoTest_FluxForm requires flux form advection' ) 
     131#endif 
    130132 
    131133      IF(lwp) THEN                    ! Print the choice 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynatf_qco.F90

    r13295 r14062  
    1 MODULE dynatfqco 
     1MODULE dynatf_qco 
    22   !!========================================================================= 
    3    !!                       ***  MODULE  dynatfqco  *** 
     3   !!                       ***  MODULE  dynatf_qco  *** 
    44   !! Ocean dynamics: time filtering 
    55   !!========================================================================= 
    … …  
    5050   USE prtctl         ! Print control 
    5151   USE timing         ! Timing 
    52 #if defined key_agrif 
    53    USE agrif_oce_interp 
    54 #endif 
    5552 
    5653   IMPLICIT NONE 
    … …  
    199196      ! JC: Would be more clever to swap variables than to make a full vertical 
    200197      ! integration 
    201       ! 
     198      ! CAUTION : calculation need to be done in the same way than see GM   
    202199      uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 
    203       uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) 
     200      uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) 
    204201      vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) 
    205       vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) 
     202      vv_b(:,:,Kmm) = (e3v_0(:,:,1) * ( 1._wp + r3v_f(:,:) * vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) 
    206203      DO jk = 2, jpkm1 
    207204         uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) 
    208          uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) 
     205         uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + (e3u_0(:,:,jk) * ( 1._wp + r3u_f(:,:) * umask(:,:,jk) )) * puu(:,:,jk,Kmm) * umask(:,:,jk) 
    209206         vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) 
    210          vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 
     207         vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + (e3v_0(:,:,jk) * ( 1._wp + r3v_f(:,:) * vmask(:,:,jk) )) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 
    211208      END DO 
    212209      uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) 
    213210      vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) 
    214       uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) 
    215       vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) 
     211      uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) 
     212      vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) 
    216213      ! 
    217214      IF( .NOT.ln_dynspg_ts ) THEN        ! output the barotropic currents 
    … …  
    235232 
    236233   !!========================================================================= 
    237 END MODULE dynatfqco 
     234END MODULE dynatf_qco 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynhpg.F90

    r14037 r14062  
    1717   !!                 !           (A. Coward) suppression of hel, wdj and rot options 
    1818   !!            3.6  !  2014-11  (P. Mathiot) hpg_isf: original code for ice shelf cavity 
     19   !!            4.2  !  2020-12  (M. Bell, A. Young) hpg_djc: revised djc scheme 
    1920   !!---------------------------------------------------------------------- 
    2021 
    … …  
    7273   INTEGER, PARAMETER ::   np_isf    =  5   ! s-coordinate similar to sco modify for isf 
    7374   ! 
    74    INTEGER, PUBLIC ::   nhpg         !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) 
     75   INTEGER, PUBLIC  ::   nhpg         !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) 
     76   ! 
     77   LOGICAL          ::   ln_hpg_djc_vnh, ln_hpg_djc_vnv                 ! flag to specify hpg_djc boundary condition type 
     78   REAL(wp), PUBLIC ::   aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions 
    7579 
    7680   !! * Substitutions 
    … …  
    155159      !! 
    156160      NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco,     & 
    157          &                 ln_hpg_djc, ln_hpg_prj, ln_hpg_isf 
     161         &                 ln_hpg_djc, ln_hpg_prj, ln_hpg_isf,     & 
     162         &                 ln_hpg_djc_vnh, ln_hpg_djc_vnv 
    158163      !!---------------------------------------------------------------------- 
    159164      ! 
    … …  
    178183      ENDIF 
    179184      ! 
    180       IF( ln_hpg_djc )   & 
    181          &   CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method',   & 
    182          &                 '   currently disabled (bugs under investigation).'        ,   & 
    183          &                 '   Please select either  ln_hpg_sco or  ln_hpg_prj instead' ) 
    184          ! 
    185       IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) )          & 
     185      IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf.OR.ln_hpg_djc) )          & 
    186186         &   CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ',   & 
    187187         &                 '   the standard jacobian formulation hpg_sco    or '    ,   & 
    … …  
    219219      ENDIF 
    220220      !                           
     221      IF ( ln_hpg_djc ) THEN 
     222         IF (ln_hpg_djc_vnh) THEN ! Von Neumann boundary condition 
     223           IF(lwp) WRITE(numout,*) '           horizontal bc: von Neumann ' 
     224           aco_bc_hor = 6.0_wp/5.0_wp 
     225           bco_bc_hor = 7.0_wp/15.0_wp 
     226         ELSE ! Linear extrapolation 
     227           IF(lwp) WRITE(numout,*) '           horizontal bc: linear extrapolation' 
     228           aco_bc_hor = 3.0_wp/2.0_wp 
     229           bco_bc_hor = 1.0_wp/2.0_wp 
     230         END IF 
     231         IF (ln_hpg_djc_vnv) THEN ! Von Neumann boundary condition 
     232           IF(lwp) WRITE(numout,*) '           vertical bc: von Neumann ' 
     233           aco_bc_vrt = 6.0_wp/5.0_wp 
     234           bco_bc_vrt = 7.0_wp/15.0_wp 
     235         ELSE ! Linear extrapolation 
     236           IF(lwp) WRITE(numout,*) '           vertical bc: linear extrapolation' 
     237           aco_bc_vrt = 3.0_wp/2.0_wp 
     238           bco_bc_vrt = 1.0_wp/2.0_wp 
     239         END IF 
     240      END IF 
    221241   END SUBROUTINE dyn_hpg_init 
    222242 
    … …  
    612632      !! 
    613633      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
     634      INTEGER  ::   iktb, iktt          ! jk indices at tracer points for top and bottom points  
    614635      REAL(wp) ::   zcoef0, zep, cffw   ! temporary scalars 
    615       REAL(wp) ::   z1_10, cffu, cffx   !    "         " 
    616       REAL(wp) ::   z1_12, cffv, cffy   !    "         " 
     636      REAL(wp) ::   z_grav_10, z1_12 
     637      REAL(wp) ::   cffu, cffx          !    "         " 
     638      REAL(wp) ::   cffv, cffy          !    "         " 
    617639      LOGICAL  ::   ll_tmp1, ll_tmp2    ! local logical variables 
    618       REAL(wp), DIMENSION(jpi,jpj)     ::   zpgu, zpgv   ! 2D workspace 
    619640      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zhpi, zhpj 
    620       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   dzx, dzy, dzz, dzu, dzv, dzw 
    621       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   drhox, drhoy, drhoz, drhou, drhov, drhow 
    622       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   rho_i, rho_j, rho_k 
     641  
     642      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdzx, zdzy, zdzz                          ! Primitive grid differences ('delta_xyz') 
     643      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdz_i, zdz_j, zdz_k                       ! Harmonic average of primitive grid differences ('d_xyz') 
     644      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdrhox, zdrhoy, zdrhoz                    ! Primitive rho differences ('delta_rho') 
     645      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdrho_i, zdrho_j, zdrho_k                 ! Harmonic average of primitive rho differences ('d_rho') 
     646      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   z_rho_i, z_rho_j, z_rho_k                 ! Face intergrals 
     647      REAL(wp), DIMENSION(jpi,jpj)     ::   zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j    ! temporary arrays  
    623648      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zcpx, zcpy   !W/D pressure filter 
    624649      !!---------------------------------------------------------------------- 
    … …  
    673698      ! Local constant initialization 
    674699      zcoef0 = - grav * 0.5_wp 
    675       z1_10  = 1._wp / 10._wp 
    676       z1_12  = 1._wp / 12._wp 
     700      z_grav_10  = grav / 10._wp 
     701      z1_12  = 1.0_wp / 12._wp 
    677702 
    678703      !---------------------------------------------------------------------------------------- 
    679       !  compute and store in provisional arrays elementary vertical and horizontal differences 
     704      !  1. compute and store elementary vertical differences in provisional arrays  
    680705      !---------------------------------------------------------------------------------------- 
    681706 
    682 !!bug gm   Not a true bug, but... dzz=e3w  for dzx, dzy verify what it is really 
    683  
    684       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    685          drhoz(ji,jj,jk) = rhd    (ji  ,jj  ,jk) - rhd    (ji,jj,jk-1) 
    686          dzz  (ji,jj,jk) = gde3w(ji  ,jj  ,jk) - gde3w(ji,jj,jk-1) 
    687          drhox(ji,jj,jk) = rhd    (ji+1,jj  ,jk) - rhd    (ji,jj,jk  ) 
    688          dzx  (ji,jj,jk) = gde3w(ji+1,jj  ,jk) - gde3w(ji,jj,jk  ) 
    689          drhoy(ji,jj,jk) = rhd    (ji  ,jj+1,jk) - rhd    (ji,jj,jk  ) 
    690          dzy  (ji,jj,jk) = gde3w(ji  ,jj+1,jk) - gde3w(ji,jj,jk  ) 
     707!!bug gm   Not a true bug, but... zdzz=e3w  for zdzx, zdzy verify what it is really 
     708 
     709      DO_3D( 1, 1, 1, 1, 2, jpkm1 )   
     710         zdrhoz(ji,jj,jk) =   rhd    (ji  ,jj  ,jk) - rhd    (ji,jj,jk-1) 
     711         zdzz  (ji,jj,jk) = - gde3w(ji  ,jj  ,jk) + gde3w(ji,jj,jk-1) 
    691712      END_3D 
    692713 
    693714      !------------------------------------------------------------------------- 
    694       ! compute harmonic averages using eq. 5.18 
     715      ! 2. compute harmonic averages for vertical differences using eq. 5.18 
    695716      !------------------------------------------------------------------------- 
    696717      zep = 1.e-15 
    697718 
    698 !!bug  gm  drhoz not defined at level 1 and used (jk-1 with jk=2) 
    699 !!bug  gm  idem for drhox, drhoy et ji=jpi and jj=jpj 
    700  
    701       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    702          cffw = 2._wp * drhoz(ji  ,jj  ,jk) * drhoz(ji,jj,jk-1) 
    703  
    704          cffu = 2._wp * drhox(ji+1,jj  ,jk) * drhox(ji,jj,jk  ) 
    705          cffx = 2._wp * dzx  (ji+1,jj  ,jk) * dzx  (ji,jj,jk  ) 
    706  
    707          cffv = 2._wp * drhoy(ji  ,jj+1,jk) * drhoy(ji,jj,jk  ) 
    708          cffy = 2._wp * dzy  (ji  ,jj+1,jk) * dzy  (ji,jj,jk  ) 
    709  
     719!! mb zdrho_k, zdz_k, zdrho_i, zdz_i, zdrho_j, zdz_j re-centred about the point (ji,jj,jk)  
     720      zdrho_k(:,:,:) = 0._wp 
     721      zdz_k  (:,:,:) = 0._wp 
     722 
     723      DO_3D( 1, 1, 1, 1, 2, jpk-2 )  
     724         cffw = 2._wp * zdrhoz(ji  ,jj  ,jk) * zdrhoz(ji,jj,jk+1) 
    710725         IF( cffw > zep) THEN 
    711             drhow(ji,jj,jk) = 2._wp *   drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1)   & 
    712                &                    / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) ) 
     726            zdrho_k(ji,jj,jk) = cffw / ( zdrhoz(ji,jj,jk) + zdrhoz(ji,jj,jk+1) ) 
     727         ENDIF 
     728         zdz_k(ji,jj,jk) = 2._wp *   zdzz(ji,jj,jk) * zdzz(ji,jj,jk+1)   & 
     729            &                  / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) ) 
     730      END_3D 
     731 
     732      !---------------------------------------------------------------------------------- 
     733      ! 3. apply boundary conditions at top and bottom using 5.36-5.37 
     734      !---------------------------------------------------------------------------------- 
     735 
     736! mb for sea-ice shelves we will need to re-write this upper boundary condition in the same form as the lower boundary condition 
     737      zdrho_k(:,:,1) = aco_bc_vrt * ( rhd    (:,:,2) - rhd    (:,:,1) ) - bco_bc_vrt * zdrho_k(:,:,2) 
     738      zdz_k  (:,:,1) = aco_bc_vrt * (-gde3w(:,:,2) + gde3w(:,:,1) ) - bco_bc_vrt * zdz_k  (:,:,2) 
     739 
     740      DO_2D( 1, 1, 1, 1 ) 
     741         IF ( mbkt(ji,jj)>1 ) THEN 
     742            iktb = mbkt(ji,jj) 
     743            zdrho_k(ji,jj,iktb) = aco_bc_vrt * (     rhd(ji,jj,iktb) -     rhd(ji,jj,iktb-1) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1) 
     744            zdz_k  (ji,jj,iktb) = aco_bc_vrt * (-gde3w(ji,jj,iktb) + gde3w(ji,jj,iktb-1) ) - bco_bc_vrt * zdz_k  (ji,jj,iktb-1)  
     745         END IF 
     746      END_2D 
     747 
     748      !-------------------------------------------------------------- 
     749      ! 4. Compute side face integrals 
     750      !------------------------------------------------------------- 
     751 
     752!! ssh replaces e3w_n ; gde3w is a depth; the formulae involve heights   
     753!! rho_k stores grav * FX / rho_0   
     754 
     755      !-------------------------------------------------------------- 
     756      ! 4. a) Upper half of top-most grid box, compute and store 
     757      !------------------------------------------------------------- 
     758! *** AY note: ssh(ji,jj,Kmm) + gde3w(ji,jj,1) = e3w(ji,jj,1) 
     759      DO_2D( 0, 1, 0, 1) 
     760         z_rho_k(ji,jj,1) =  grav * ( ssh(ji,jj,Kmm) + gde3w(ji,jj,1) )                        &  
     761            &                     * (  rhd(ji,jj,1)                                        & 
     762            &                     + 0.5_wp * (   rhd    (ji,jj,2) - rhd    (ji,jj,1) ) & 
     763            &                              * (   ssh   (ji,jj,Kmm) + gde3w(ji,jj,1) )          & 
     764            &                              / ( - gde3w(ji,jj,2) + gde3w(ji,jj,1) )  ) 
     765      END_2D 
     766 
     767      !-------------------------------------------------------------- 
     768      ! 4. b) Interior faces, compute and store 
     769      !------------------------------------------------------------- 
     770 
     771      DO_3D( 0, 1, 0, 1, 2, jpkm1 ) 
     772         z_rho_k(ji,jj,jk) = zcoef0 * (   rhd    (ji,jj,jk) + rhd    (ji,jj,jk-1) )                                   & 
     773            &                       * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) )                                               & 
     774            &                       + z_grav_10 * (                                                                           & 
     775            &     (   zdrho_k  (ji,jj,jk) - zdrho_k  (ji,jj,jk-1) )                                                           & 
     776            &   * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) - z1_12 * ( zdz_k  (ji,jj,jk) + zdz_k  (ji,jj,jk-1) ) )             & 
     777            &   - ( zdz_k    (ji,jj,jk) - zdz_k    (ji,jj,jk-1) )                                                             & 
     778            &   * ( rhd    (ji,jj,jk) - rhd    (ji,jj,jk-1) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) )   & 
     779            &                             ) 
     780      END_3D 
     781 
     782      !---------------------------------------------------------------------------------------- 
     783      !  5. compute and store elementary horizontal differences in provisional arrays  
     784      !---------------------------------------------------------------------------------------- 
     785 
     786      DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     787         zdrhox(ji,jj,jk) =   rhd    (ji+1,jj  ,jk) - rhd    (ji,jj,jk  ) 
     788         zdzx  (ji,jj,jk) = - gde3w(ji+1,jj  ,jk) + gde3w(ji,jj,jk  ) 
     789         zdrhoy(ji,jj,jk) =   rhd    (ji  ,jj+1,jk) - rhd    (ji,jj,jk  ) 
     790         zdzy  (ji,jj,jk) = - gde3w(ji  ,jj+1,jk) + gde3w(ji,jj,jk  ) 
     791      END_3D 
     792 
     793      CALL lbc_lnk_multi( 'dynhpg', zdrhox, 'U', 1., zdzx, 'U', 1., zdrhoy, 'V', 1., zdzy, 'V', 1. )  
     794 
     795      !------------------------------------------------------------------------- 
     796      ! 6. compute harmonic averages using eq. 5.18 
     797      !------------------------------------------------------------------------- 
     798 
     799      DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 
     800         cffu = 2._wp * zdrhox(ji-1,jj  ,jk) * zdrhox(ji,jj,jk  ) 
     801         IF( cffu > zep ) THEN 
     802            zdrho_i(ji,jj,jk) = cffu / ( zdrhox(ji-1,jj,jk) + zdrhox(ji,jj,jk) ) 
    713803         ELSE 
    714             drhow(ji,jj,jk) = 0._wp 
    715          ENDIF 
    716  
    717          dzw(ji,jj,jk) = 2._wp *   dzz(ji,jj,jk) * dzz(ji,jj,jk-1)   & 
    718             &                  / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) ) 
    719  
    720          IF( cffu > zep ) THEN 
    721             drhou(ji,jj,jk) = 2._wp *   drhox(ji+1,jj,jk) * drhox(ji,jj,jk)   & 
    722                &                    / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) ) 
     804            zdrho_i(ji,jj,jk ) = 0._wp 
     805         ENDIF 
     806 
     807         cffx = 2._wp * zdzx  (ji-1,jj  ,jk) * zdzx  (ji,jj,jk  ) 
     808         IF( cffx > zep ) THEN 
     809            zdz_i(ji,jj,jk) = cffx / ( zdzx(ji-1,jj,jk) + zdzx(ji,jj,jk) ) 
    723810         ELSE 
    724             drhou(ji,jj,jk ) = 0._wp 
    725          ENDIF 
    726  
    727          IF( cffx > zep ) THEN 
    728             dzu(ji,jj,jk) = 2._wp *   dzx(ji+1,jj,jk) * dzx(ji,jj,jk)   & 
    729                &                  / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) ) 
     811            zdz_i(ji,jj,jk) = 0._wp 
     812         ENDIF 
     813 
     814         cffv = 2._wp * zdrhoy(ji  ,jj-1,jk) * zdrhoy(ji,jj,jk  ) 
     815         IF( cffv > zep ) THEN 
     816            zdrho_j(ji,jj,jk) = cffv / ( zdrhoy(ji,jj-1,jk) + zdrhoy(ji,jj,jk) ) 
    730817         ELSE 
    731             dzu(ji,jj,jk) = 0._wp 
    732          ENDIF 
    733  
    734          IF( cffv > zep ) THEN 
    735             drhov(ji,jj,jk) = 2._wp *   drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk)   & 
    736                &                    / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) ) 
     818            zdrho_j(ji,jj,jk) = 0._wp 
     819         ENDIF 
     820 
     821         cffy = 2._wp * zdzy  (ji  ,jj-1,jk) * zdzy  (ji,jj,jk  ) 
     822         IF( cffy > zep ) THEN 
     823            zdz_j(ji,jj,jk) = cffy / ( zdzy(ji,jj-1,jk) + zdzy(ji,jj,jk) ) 
    737824         ELSE 
    738             drhov(ji,jj,jk) = 0._wp 
    739          ENDIF 
    740  
    741          IF( cffy > zep ) THEN 
    742             dzv(ji,jj,jk) = 2._wp *   dzy(ji,jj+1,jk) * dzy(ji,jj,jk)   & 
    743                &                  / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) ) 
    744          ELSE 
    745             dzv(ji,jj,jk) = 0._wp 
    746          ENDIF 
    747  
    748       END_3D 
     825            zdz_j(ji,jj,jk) = 0._wp 
     826         ENDIF 
     827      END_3D 
     828       
     829!!! Note that zdzx, zdzy, zdzz, zdrhox, zdrhoy and zdrhoz should NOT be used beyond this point       
    749830 
    750831      !---------------------------------------------------------------------------------- 
    751       ! apply boundary conditions at top and bottom using 5.36-5.37 
     832      ! 6B. apply boundary conditions at side boundaries using 5.36-5.37 
    752833      !---------------------------------------------------------------------------------- 
    753       drhow(:,:, 1 ) = 1.5_wp * ( drhoz(:,:, 2 ) - drhoz(:,:,  1  ) ) - 0.5_wp * drhow(:,:,  2  ) 
    754       drhou(:,:, 1 ) = 1.5_wp * ( drhox(:,:, 2 ) - drhox(:,:,  1  ) ) - 0.5_wp * drhou(:,:,  2  ) 
    755       drhov(:,:, 1 ) = 1.5_wp * ( drhoy(:,:, 2 ) - drhoy(:,:,  1  ) ) - 0.5_wp * drhov(:,:,  2  ) 
    756  
    757       drhow(:,:,jpk) = 1.5_wp * ( drhoz(:,:,jpk) - drhoz(:,:,jpkm1) ) - 0.5_wp * drhow(:,:,jpkm1) 
    758       drhou(:,:,jpk) = 1.5_wp * ( drhox(:,:,jpk) - drhox(:,:,jpkm1) ) - 0.5_wp * drhou(:,:,jpkm1) 
    759       drhov(:,:,jpk) = 1.5_wp * ( drhoy(:,:,jpk) - drhoy(:,:,jpkm1) ) - 0.5_wp * drhov(:,:,jpkm1) 
    760  
     834 
     835      DO jk = 1, jpkm1 
     836         zz_drho_i(:,:) = zdrho_i(:,:,jk) 
     837         zz_dz_i  (:,:) = zdz_i  (:,:,jk) 
     838         zz_drho_j(:,:) = zdrho_j(:,:,jk) 
     839         zz_dz_j  (:,:) = zdz_j  (:,:,jk) 
     840         DO_2D( 0, 1, 0, 1) 
     841            ! Walls coming from left: should check from 2 to jpi-1 (and jpj=2-jpj) 
     842            IF (ji < jpi) THEN 
     843               IF ( umask(ji,jj,jk) > 0.5_wp .AND. umask(ji-1,jj,jk) < 0.5_wp .AND. umask(ji+1,jj,jk) > 0.5_wp)  THEN   
     844                  zz_drho_i(ji,jj) = aco_bc_hor * ( rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) ) - bco_bc_hor * zdrho_i(ji+1,jj,jk)  
     845                  zz_dz_i  (ji,jj) = aco_bc_hor * (-gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_i  (ji+1,jj,jk) 
     846               END IF 
     847            END IF 
     848            ! Walls coming from right: should check from 3 to jpi (and jpj=2-jpj) 
     849            IF (ji > 2) THEN 
     850               IF ( umask(ji,jj,jk) < 0.5_wp .AND. umask(ji-1,jj,jk) > 0.5_wp .AND. umask(ji-2,jj,jk) > 0.5_wp) THEN 
     851                  zz_drho_i(ji,jj) = aco_bc_hor * ( rhd    (ji,jj,jk) - rhd    (ji-1,jj,jk) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk)   
     852                  zz_dz_i  (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji-1,jj,jk) ) - bco_bc_hor * zdz_i  (ji-1,jj,jk) 
     853               END IF 
     854            END IF 
     855            ! Walls coming from left: should check from 2 to jpj-1 (and jpi=2-jpi) 
     856            IF (jj < jpj) THEN 
     857               IF ( vmask(ji,jj,jk) > 0.5_wp .AND. vmask(ji,jj-1,jk) < 0.5_wp .AND. vmask(ji,jj+1,jk) > 0.5_wp)  THEN 
     858                  zz_drho_j(ji,jj) = aco_bc_hor * ( rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk) 
     859                  zz_dz_j  (ji,jj) = aco_bc_hor * (-gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_j  (ji,jj+1,jk) 
     860               END IF 
     861            END IF  
     862            ! Walls coming from right: should check from 3 to jpj (and jpi=2-jpi) 
     863            IF (jj > 2) THEN 
     864               IF ( vmask(ji,jj,jk) < 0.5_wp .AND. vmask(ji,jj-1,jk) > 0.5_wp .AND. vmask(ji,jj-2,jk) > 0.5_wp) THEN  
     865                  zz_drho_j(ji,jj) = aco_bc_hor * ( rhd    (ji,jj,jk) - rhd    (ji,jj-1,jk) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk)  
     866                  zz_dz_j  (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji,jj-1,jk) ) - bco_bc_hor * zdz_j  (ji,jj-1,jk) 
     867               END IF 
     868            END IF 
     869         END_2D 
     870         zdrho_i(:,:,jk) = zz_drho_i(:,:) 
     871         zdz_i  (:,:,jk) = zz_dz_i  (:,:) 
     872         zdrho_j(:,:,jk) = zz_drho_j(:,:) 
     873         zdz_j  (:,:,jk) = zz_dz_j  (:,:) 
     874      END DO 
    761875 
    762876      !-------------------------------------------------------------- 
    763       ! Upper half of top-most grid box, compute and store 
     877      ! 7. Calculate integrals on side faces   
    764878      !------------------------------------------------------------- 
    765879 
    766 !!bug gm   :  e3w-gde3w(:,:,:) = 0.5*e3w  ....  and gde3w(:,:,2)-gde3w(:,:,1)=e3w(:,:,2,Kmm) ....   to be verified 
    767 !          true if gde3w(:,:,:) is really defined as the sum of the e3w scale factors as, it seems to me, it should be 
    768  
    769       DO_2D( 0, 0, 0, 0 ) 
    770          rho_k(ji,jj,1) = -grav * ( e3w(ji,jj,1,Kmm) - gde3w(ji,jj,1) )               & 
    771             &                   * (  rhd(ji,jj,1)                                     & 
    772             &                     + 0.5_wp * ( rhd    (ji,jj,2) - rhd    (ji,jj,1) )  & 
    773             &                              * ( e3w  (ji,jj,1,Kmm) - gde3w(ji,jj,1) )  & 
    774             &                              / ( gde3w(ji,jj,2) - gde3w(ji,jj,1) )  ) 
    775       END_2D 
    776  
    777 !!bug gm    : here also, simplification is possible 
    778 !!bug gm    : optimisation: 1/10 and 1/12 the division should be done before the loop 
    779  
    780       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    781  
    782          rho_k(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj,jk) + rhd    (ji,jj,jk-1) )                                   & 
    783             &                     * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) )                                   & 
    784             &            - grav * z1_10 * (                                                                   & 
    785             &     ( drhow  (ji,jj,jk) - drhow  (ji,jj,jk-1) )                                                     & 
    786             &   * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) - z1_12 * ( dzw  (ji,jj,jk) + dzw  (ji,jj,jk-1) ) )   & 
    787             &   - ( dzw    (ji,jj,jk) - dzw    (ji,jj,jk-1) )                                                     & 
    788             &   * ( rhd    (ji,jj,jk) - rhd    (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) )   & 
    789             &                             ) 
    790  
    791          rho_i(ji,jj,jk) = zcoef0 * ( rhd    (ji+1,jj,jk) + rhd    (ji,jj,jk) )                                   & 
    792             &                     * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) )                                   & 
    793             &            - grav* z1_10 * (                                                                    & 
    794             &     ( drhou  (ji+1,jj,jk) - drhou  (ji,jj,jk) )                                                     & 
    795             &   * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzu  (ji+1,jj,jk) + dzu  (ji,jj,jk) ) )   & 
    796             &   - ( dzu    (ji+1,jj,jk) - dzu    (ji,jj,jk) )                                                     & 
    797             &   * ( rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) )   & 
    798             &                            ) 
    799  
    800          rho_j(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj+1,jk) + rhd    (ji,jj,jk) )                                 & 
    801             &                     * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) )                                   & 
    802             &            - grav* z1_10 * (                                                                    & 
    803             &     ( drhov  (ji,jj+1,jk) - drhov  (ji,jj,jk) )                                                     & 
    804             &   * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzv  (ji,jj+1,jk) + dzv  (ji,jj,jk) ) )   & 
    805             &   - ( dzv    (ji,jj+1,jk) - dzv    (ji,jj,jk) )                                                     & 
    806             &   * ( rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) )   & 
    807             &                            ) 
    808  
    809       END_3D 
    810       CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) 
    811       ! 
    812       ! --------------- 
    813       !  Surface pressure gradient to be removed 
    814       ! --------------- 
    815       DO_2D( 0, 0, 0, 0 ) 
    816          zpgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 
    817          zpgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 
    818       END_2D 
     880      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     881! two -ve signs cancel in next two lines (within zcoef0 and because gde3w is a depth not a height) 
     882         z_rho_i(ji,jj,jk) = zcoef0 * ( rhd    (ji+1,jj,jk) + rhd    (ji,jj,jk) )                                       & 
     883             &                    * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) )                                     
     884         IF ( umask(ji-1, jj, jk) > 0.5 .OR. umask(ji+1, jj, jk) > 0.5 ) THEN 
     885            z_rho_i(ji,jj,jk) = z_rho_i(ji,jj,jk) - z_grav_10 * (                                                               & 
     886             &     (   zdrho_i  (ji+1,jj,jk) - zdrho_i  (ji,jj,jk) )                                                            & 
     887             &   * ( - gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_i  (ji+1,jj,jk) + zdz_i  (ji,jj,jk) ) )              & 
     888             &   - (   zdz_i    (ji+1,jj,jk) - zdz_i    (ji,jj,jk) )                                                            & 
     889             &   * (   rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) )  & 
     890             &                                               ) 
     891         END IF 
     892   
     893         z_rho_j(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj+1,jk) + rhd    (ji,jj,jk) )                                       & 
     894             &                    * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) )                                   
     895         IF ( vmask(ji, jj-1, jk) > 0.5 .OR. vmask(ji, jj+1, jk) > 0.5 ) THEN 
     896            z_rho_j(ji,jj,jk) = z_rho_j(ji,jj,jk) - z_grav_10 * (                                                               & 
     897             &     (   zdrho_j  (ji,jj+1,jk) - zdrho_j  (ji,jj,jk) )                                                            & 
     898             &   * ( - gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_j  (ji,jj+1,jk) + zdz_j  (ji,jj,jk) ) )              & 
     899             &   - (   zdz_j    (ji,jj+1,jk) - zdz_j    (ji,jj,jk) )                                                            & 
     900             &   * (   rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) )  & 
     901             &                                                 ) 
     902         END IF 
     903      END_3D 
     904 
     905      !-------------------------------------------------------------- 
     906      ! 8. Integrate in the vertical    
     907      !------------------------------------------------------------- 
    819908      ! 
    820909      ! --------------- 
    … …  
    822911      ! --------------- 
    823912      DO_2D( 0, 0, 0, 0 ) 
    824          zhpi(ji,jj,1) = ( rho_k(ji+1,jj  ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 
    825          zhpj(ji,jj,1) = ( rho_k(ji  ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 
     913         zhpi(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj  ,1) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 
     914         zhpj(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji  ,jj+1,1) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 
    826915         IF( ln_wd_il ) THEN 
    827916           zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
    … …  
    829918         ENDIF 
    830919         ! add to the general momentum trend 
    831          puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) - zpgu(ji,jj) 
    832          pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) - zpgv(ji,jj) 
     920         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) 
     921         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) 
    833922      END_2D 
    834923 
    … …  
    838927      DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    839928         ! hydrostatic pressure gradient along s-surfaces 
    840          zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                & 
    841             &           + (  ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk  ) )    & 
    842             &              - ( rho_i(ji  ,jj,jk) - rho_i(ji,jj,jk-1) )  ) * r1_e1u(ji,jj) 
    843          zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)                                & 
    844             &           + (  ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk  ) )    & 
    845             &               -( rho_j(ji,jj  ,jk) - rho_j(ji,jj,jk-1) )  ) * r1_e2v(ji,jj) 
     929         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                                     & 
     930            &           + (  ( z_rho_k(ji,jj,jk) - z_rho_k(ji+1,jj,jk  ) )                     & 
     931            &              - ( z_rho_i(ji,jj,jk) - z_rho_i(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj) 
     932         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)                                                     & 
     933            &           + (  ( z_rho_k(ji,jj,jk) - z_rho_k(ji,jj+1,jk  ) )                     & 
     934            &               -( z_rho_j(ji,jj,jk) - z_rho_j(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj) 
    846935         IF( ln_wd_il ) THEN 
    847936           zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
    … …  
    849938         ENDIF 
    850939         ! add to the general momentum trend 
    851          puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) - zpgu(ji,jj) 
    852          pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) - zpgv(ji,jj) 
     940         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) 
     941         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) 
    853942      END_3D 
    854943      ! 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynldf_lap_blp.F90

    r14037 r14062  
    55   !!====================================================================== 
    66   !! History : 3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian 
     7   !!           4.0  ! 2020-04  (A. Nasser, G. Madec)  Add symmetric mixing tensor  
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1920   USE in_out_manager ! I/O manager 
    2021   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    21  
     22   USE lib_mpp 
     23    
    2224   IMPLICIT NONE 
    2325   PRIVATE 
    … …  
    4749      !! 
    4850      !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. 
     51      !! 
     52      !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/  
    4953      !!---------------------------------------------------------------------- 
    5054      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    5761      REAL(wp) ::   zsign        ! local scalars 
    5862      REAL(wp) ::   zua, zva     ! local scalars 
    59       REAL(wp), DIMENSION(jpi,jpj) ::   zcur, zdiv 
     63      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zcur, zdiv 
     64      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zten, zshe   ! tension (diagonal) and shearing (anti-diagonal) terms 
    6065      !!---------------------------------------------------------------------- 
    6166      ! 
    … …  
    7075      ENDIF 
    7176      ! 
    72       !                                                ! =============== 
    73       DO jk = 1, jpkm1                                 ! Horizontal slab 
    74          !                                             ! =============== 
    75          DO_2D( 0, 1, 0, 1 ) 
    76             !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1) 
    77             zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       &   ! ahmf already * by fmask 
    78                &     * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
    79                &        - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
    80             !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
    81             zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)               &   ! ahmt already * by tmask 
    82                &     * (  e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk)  & 
    83                &        + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk)  ) 
    84          END_2D 
     77      SELECT CASE( nn_dynldf_typ )   
     78      !               
     79      CASE ( np_typ_rot )       !==  Vorticity-Divergence operator  ==! 
    8580         ! 
    86          DO_2D( 0, 0, 0, 0 )                       ! - curl( curl) + grad( div ) 
    87             pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * (    &    ! * by umask is mandatory for dyn_ldf_blp use 
    88                &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 
    89                &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                      ) 
     81         ALLOCATE( zcur(jpi,jpj) , zdiv(jpi,jpj) ) 
     82         ! 
     83         DO jk = 1, jpkm1                                 ! Horizontal slab 
     84            ! 
     85            DO_2D( 0, 1, 0, 1 ) 
     86               !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1) 
     87               zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       &   ! ahmf already * by fmask 
     88                  &     * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
     89                  &        - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
     90               !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
     91               zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)               &   ! ahmt already * by tmask 
     92                  &     * (  e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk)  & 
     93                  &        + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk)  ) 
     94            END_2D 
     95            ! 
     96            DO_2D( 0, 0, 0, 0 )                       ! - curl( curl) + grad( div ) 
     97               pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * (    &    ! * by umask is mandatory for dyn_ldf_blp use 
     98                  &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 
     99                  &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                      ) 
    90100               ! 
    91             pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * (    &    ! * by vmask is mandatory for dyn_ldf_blp use 
    92                &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm)   & 
    93                &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                      ) 
    94          END_2D 
    95          !                                             ! =============== 
    96       END DO                                           !   End of slab 
    97       !                                                ! =============== 
     101               pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * (    &    ! * by vmask is mandatory for dyn_ldf_blp use 
     102                  &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm)   & 
     103                  &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                      ) 
     104            END_2D 
     105            ! 
     106         END DO                                           !   End of slab 
     107         ! 
     108         DEALLOCATE( zcur , zdiv ) 
     109         ! 
     110      CASE ( np_typ_sym )       !==  Symmetric operator  ==! 
     111         ! 
     112         ALLOCATE( zten(jpi,jpj) , zshe(jpi,jpj) ) 
     113         ! 
     114         DO jk = 1, jpkm1                                 ! Horizontal slab 
     115            ! 
     116            DO_2D( 0, 1, 0, 1 ) 
     117               !                                      ! shearing stress component (F-point)   NB : ahmf has already been multiplied by fmask 
     118               zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk)                                                              & 
     119                  &     * (    e1f(ji-1,jj-1)    * r1_e2f(ji-1,jj-1)                                             & 
     120                  &         * ( pu(ji-1,jj  ,jk) * r1_e1u(ji-1,jj  )  - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) )   & 
     121                  &         +  e2f(ji-1,jj-1)    * r1_e1f(ji-1,jj-1)                                             & 
     122                  &         * ( pv(ji  ,jj-1,jk) * r1_e2v(ji  ,jj-1)  - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) )   )  
     123               !                                      ! tension stress component (T-point)   NB : ahmt has already been multiplied by tmask 
     124               zten(ji,jj)    = ahmt(ji,jj,jk)                                                       & 
     125                  &     * (    e2t(ji,jj)    * r1_e1t(ji,jj)                                         & 
     126                  &         * ( pu(ji,jj,jk) * r1_e2u(ji,jj)  - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) )   & 
     127                  &         -  e1t(ji,jj)    * r1_e2t(ji,jj)                                         & 
     128                  &         * ( pv(ji,jj,jk) * r1_e1v(ji,jj)  - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) )   )    
     129            END_2D 
     130            ! 
     131            DO_2D( 0, 0, 0, 0 ) 
     132               pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)                               & 
     133                  &    * (   (   zten(ji+1,jj  ) * e2t(ji+1,jj  )*e2t(ji+1,jj  ) * e3t(ji+1,jj  ,jk,Kmm)                       & 
     134                  &            - zten(ji  ,jj  ) * e2t(ji  ,jj  )*e2t(ji  ,jj  ) * e3t(ji  ,jj  ,jk,Kmm) ) * r1_e2u(ji,jj)     &                                                     
     135                  &        + (   zshe(ji  ,jj  ) * e1f(ji  ,jj  )*e1f(ji  ,jj  ) * e3f(ji  ,jj  ,jk)                           & 
     136                  &            - zshe(ji  ,jj-1) * e1f(ji  ,jj-1)*e1f(ji  ,jj-1) * e3f(ji  ,jj-1,jk)     ) * r1_e1u(ji,jj) )    
     137               ! 
     138               pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)                               & 
     139                  &    * (   (   zshe(ji  ,jj  ) * e2f(ji  ,jj  )*e2f(ji  ,jj  ) * e3f(ji  ,jj  ,jk)                           & 
     140                  &            - zshe(ji-1,jj  ) * e2f(ji-1,jj  )*e2f(ji-1,jj  ) * e3f(ji-1,jj  ,jk)     ) * r1_e2v(ji,jj)     & 
     141                  &        - (   zten(ji  ,jj+1) * e1t(ji  ,jj+1)*e1t(ji  ,jj+1) * e3t(ji  ,jj+1,jk,Kmm)                       & 
     142                  &            - zten(ji  ,jj  ) * e1t(ji  ,jj  )*e1t(ji  ,jj  ) * e3t(ji  ,jj  ,jk,Kmm) ) * r1_e1v(ji,jj) ) 
     143               ! 
     144            END_2D 
     145            ! 
     146         END DO 
     147         ! 
     148         DEALLOCATE( zten , zshe ) 
     149         ! 
     150      END SELECT 
    98151      ! 
    99152   END SUBROUTINE dyn_ldf_lap 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynspg_ts.F90

    r14037 r14062  
    295295      ENDIF 
    296296      ! 
    297       !                                   !=  Add atmospheric pressure forcing  =! 
    298       !                                   !  ----------------------------------  ! 
    299       IF( ln_bt_fw ) THEN                        ! Add wind forcing 
     297      !                                   !=  Add wind forcing  =! 
     298      !                                   !  ------------------  ! 
     299      IF( ln_bt_fw ) THEN 
    300300         DO_2D( 0, 0, 0, 0 ) 
    301301            zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kmm) 
    … …  
    375375      ! 
    376376      IF( ln_linssh ) THEN    ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 
    377          zhup2_e(:,:) = hu(:,:,Kmm) 
    378          zhvp2_e(:,:) = hv(:,:,Kmm) 
    379          zhtp2_e(:,:) = ht(:,:) 
    380       ENDIF 
    381       ! 
    382       IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                     
    383          sshn_e(:,:) =    pssh(:,:,Kmm)             
     377         zhup2_e(:,:) = hu_0(:,:) 
     378         zhvp2_e(:,:) = hv_0(:,:) 
     379         zhtp2_e(:,:) = ht_0(:,:) 
     380      ENDIF 
     381      ! 
     382      IF( ln_bt_fw ) THEN                 ! FORWARD integration: start from NOW fields                     
     383         sshn_e(:,:) =    pssh (:,:,Kmm)             
    384384         un_e  (:,:) =    puu_b(:,:,Kmm)             
    385385         vn_e  (:,:) =    pvv_b(:,:,Kmm) 
    … …  
    390390         hvr_e (:,:) = r1_hv(:,:,Kmm) 
    391391      ELSE                                ! CENTRED integration: start from BEFORE fields 
    392          sshn_e(:,:) =    pssh(:,:,Kbb) 
     392         sshn_e(:,:) =    pssh (:,:,Kbb) 
    393393         un_e  (:,:) =    puu_b(:,:,Kbb)          
    394394         vn_e  (:,:) =    pvv_b(:,:,Kbb) 
    … …  
    401401      ! 
    402402      ! Initialize sums: 
    403       puu_b  (:,:,Kaa) = 0._wp       ! After barotropic velocities (or transport if flux form)           
    404       pvv_b  (:,:,Kaa) = 0._wp 
     403      puu_b (:,:,Kaa) = 0._wp       ! After barotropic velocities (or transport if flux form)           
     404      pvv_b (:,:,Kaa) = 0._wp 
    405405      pssh  (:,:,Kaa) = 0._wp       ! Sum for after averaged sea level 
    406       un_adv(:,:) = 0._wp       ! Sum for now transport issued from ts loop 
    407       vn_adv(:,:) = 0._wp 
     406      un_adv(:,:)     = 0._wp       ! Sum for now transport issued from ts loop 
     407      vn_adv(:,:)     = 0._wp 
    408408      ! 
    409409      IF( ln_wd_dl ) THEN 
    … …  
    464464            ! 
    465465            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
     466#if defined key_qcoTest_FluxForm 
     467            !                                ! 'key_qcoTest_FluxForm' : simple ssh average 
     468            DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
     469               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * (  zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj  )  ) * ssumask(ji,jj) 
     470            END_2D 
     471            DO_2D( 1, 0, 1, 1 ) 
     472               zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * (  zsshp2_e(ji,jj) + zsshp2_e(ji  ,jj+1)  ) * ssvmask(ji,jj) 
     473            END_2D 
     474#else 
     475            !                                ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 
    466476            DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    467477               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
    … …  
    474484                    &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
    475485            END_2D 
     486#endif                
    476487            ! 
    477488         ENDIF 
    … …  
    529540         !   
    530541         ! Sea Surface Height at u-,v-points (vvl case only) 
    531          IF( .NOT.ln_linssh ) THEN                                 
     542         IF( .NOT.ln_linssh ) THEN 
     543#if defined key_qcoTest_FluxForm 
     544            !                                ! 'key_qcoTest_FluxForm' : simple ssh average 
     545            DO_2D( 1, 1, 1, 0 ) 
     546               zsshu_a(ji,jj) = r1_2 * (  ssha_e(ji,jj) + ssha_e(ji+1,jj  )  ) * ssumask(ji,jj) 
     547            END_2D 
     548            DO_2D( 1, 0, 1, 1 ) 
     549               zsshv_a(ji,jj) = r1_2 * (  ssha_e(ji,jj) + ssha_e(ji  ,jj+1)  ) * ssvmask(ji,jj) 
     550            END_2D 
     551#else 
    532552            DO_2D( 0, 0, 0, 0 ) 
    533                zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
    534                   &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    535                   &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
    536                zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
    537                   &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    538                   &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
    539             END_2D 
    540          ENDIF    
     553               zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji  ,jj  ) * ssha_e(ji  ,jj  )   & 
     554                  &                                      + e1e2t(ji+1,jj  ) * ssha_e(ji+1,jj  ) ) * ssumask(ji,jj) 
     555               zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji  ,jj  ) * ssha_e(ji  ,jj  )   & 
     556                  &                                      + e1e2t(ji  ,jj+1) * ssha_e(ji  ,jj+1) ) * ssvmask(ji,jj) 
     557            END_2D 
     558#endif 
     559         ENDIF 
    541560         !          
    542561         ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 
    … …  
    613632               !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
    614633               !                    ! backward interpolated depth used in spg terms at jn+1/2 
     634#if defined key_qcoTest_FluxForm 
     635            !                                ! 'key_qcoTest_FluxForm' : simple ssh average 
     636               zhu_bck = hu_0(ji,jj) + r1_2 * (  zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj  )  ) * ssumask(ji,jj) 
     637               zhv_bck = hv_0(ji,jj) + r1_2 * (  zsshp2_e(ji,jj) + zsshp2_e(ji  ,jj+1)  ) * ssvmask(ji,jj) 
     638#else 
    615639               zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
    616640                    &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    617641               zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
    618642                    &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     643#endif 
    619644               !                    ! inverse depth at jn+1 
    620645               z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    … …  
    635660         IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 
    636661            DO_2D( 0, 0, 0, 0 ) 
    637                   ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj)) 
    638                   va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj)) 
     662               ua_e(ji,jj) =  ua_e(ji,jj) / ( 1._wp - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj) ) 
     663               va_e(ji,jj) =  va_e(ji,jj) / ( 1._wp - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj) ) 
    639664            END_2D 
    640665         ENDIF 
    641666        
    642667         IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 
    643             hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 
    644             hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 
    645             hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 
    646             hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 
     668            hu_e (2:jpim1,2:jpjm1) =    hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 
     669            hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / (  hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 
     670            hv_e (2:jpim1,2:jpjm1) =    hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 
     671            hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / (  hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 
    647672         ENDIF 
    648673         ! 
    … …  
    732757      ELSE 
    733758         ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points 
     759#if defined key_qcoTest_FluxForm 
     760         !                                ! 'key_qcoTest_FluxForm' : simple ssh average 
    734761         DO_2D( 1, 0, 1, 0 ) 
    735             zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) & 
    736                &              * ( e1e2t(ji  ,jj) * pssh(ji  ,jj,Kaa)      & 
    737                &              +   e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) 
    738             zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) & 
    739                &              * ( e1e2t(ji,jj  ) * pssh(ji,jj  ,Kaa)      & 
    740                &              +   e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) 
    741          END_2D 
     762            zsshu_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji+1,jj  ,Kaa) ) * ssumask(ji,jj) 
     763            zsshv_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji  ,jj+1,Kaa) ) * ssvmask(ji,jj) 
     764         END_2D 
     765#else 
     766         DO_2D( 1, 0, 1, 0 ) 
     767            zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji  ,jj) * pssh(ji  ,jj,Kaa)   & 
     768               &                                      + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) * ssumask(ji,jj) 
     769            zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji,jj  ) * pssh(ji,jj  ,Kaa)   & 
     770               &                                      + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) 
     771         END_2D 
     772#endif    
    742773         CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    743774         ! 
    744775         DO jk=1,jpkm1 
    745             puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 
    746             pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 
     776            puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm)   & 
     777               &             * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 
     778            pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm)   & 
     779               &             * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 
    747780         END DO 
    748781         ! Save barotropic velocities not transport: 
    … …  
    888921      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    889922         !                                   ! --------------- 
    890          IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN    !* Read the restart file 
     923         IF( ln_rstart .AND. ln_bt_fw .AND. .NOT.l_1st_euler ) THEN    !* Read the restart file 
    891924            CALL iom_get( numror, jpdom_auto, 'ub2_b'  , ub2_b  (:,:), cd_type = 'U', psgn = -1._wp )    
    892925            CALL iom_get( numror, jpdom_auto, 'vb2_b'  , vb2_b  (:,:), cd_type = 'V', psgn = -1._wp )  
    … …  
    10491082      !! although they should be updated in the variable volume case. Not a big approximation. 
    10501083      !! To remove this approximation, copy lines below inside barotropic loop 
    1051       !! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 
     1084      !! and update depths at T- points (ht) at each barotropic time step 
    10521085      !! 
    10531086      !! Compute zwz = f / ( height of the water colomn ) 
    … …  
    10561089      INTEGER  ::   ji ,jj, jk              ! dummy loop indices 
    10571090      REAL(wp) ::   z1_ht 
    1058       REAL(wp), DIMENSION(jpi,jpj) :: zhf 
    10591091      !!---------------------------------------------------------------------- 
    10601092      ! 
    10611093      SELECT CASE( nvor_scheme ) 
    1062       CASE( np_EEN )                != EEN scheme using e3f energy & enstrophy scheme 
    1063          SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
     1094      CASE( np_EEN, np_ENE, np_ENS , np_MIX )   !=  schemes using the same e3f definition 
     1095         SELECT CASE( nn_e3f_typ )                  !* ff_f/e3 at F-point 
    10641096         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    1065             DO_2D( 1, 0, 1, 0 ) 
    1066                zwz(ji,jj) =   ( ht(ji  ,jj+1) + ht(ji+1,jj+1) +                    & 
    1067                     &           ht(ji  ,jj  ) + ht(ji+1,jj  )  ) * 0.25_wp   
     1097            DO_2D( 0, 0, 0, 0 ) 
     1098               zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1)   & 
     1099                    &       + ht(ji,jj  ) + ht(ji+1,jj  ) ) * 0.25_wp   
    10681100               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    10691101            END_2D 
    10701102         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    1071             DO_2D( 1, 0, 1, 0 ) 
    1072                zwz(ji,jj) =             (  ht  (ji  ,jj+1) + ht  (ji+1,jj+1)      & 
    1073                     &                    + ht  (ji  ,jj  ) + ht  (ji+1,jj  )  )   & 
    1074                     &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
    1075                     &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
     1103            DO_2D( 0, 0, 0, 0 ) 
     1104               zwz(ji,jj) =     (    ht(ji,jj+1) +     ht(ji+1,jj+1)      & 
     1105                    &            +   ht(ji,jj  ) +     ht(ji+1,jj  )  )   & 
     1106                    &    / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1)      & 
     1107                    &          + ssmask(ji,jj  ) + ssmask(ji+1,jj  ) , 1._wp  )   ) 
    10761108               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    10771109            END_2D 
    10781110         END SELECT 
    10791111         CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
    1080          ! 
    1081          ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1112      END SELECT 
     1113      ! 
     1114      SELECT CASE( nvor_scheme ) 
     1115      CASE( np_EEN ) 
     1116         ! 
     1117         ftne(1,:) = 0._wp   ;   ftnw(1,:) = 0._wp   ;   ftse(1,:) = 0._wp   ;   ftsw(1,:) = 0._wp 
    10821118         DO_2D( 0, 1, 0, 1 ) 
    10831119            ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
    … …  
    10871123         END_2D 
    10881124         ! 
    1089       CASE( np_EET )                  != EEN scheme using e3t energy conserving scheme 
    1090          ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1125      CASE( np_EET )                            != EEN scheme using e3t energy conserving scheme 
     1126         ftne(1,:) = 0._wp   ;   ftnw(1,:) = 0._wp   ;   ftse(1,:) = 0._wp   ;  ftsw(1,:) = 0._wp 
    10911127         DO_2D( 0, 1, 0, 1 ) 
    10921128            z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 
    … …  
    10971133         END_2D 
    10981134         ! 
    1099       CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
    1100          ! 
    1101          zwz(:,:) = 0._wp 
    1102          zhf(:,:) = 0._wp 
    1103           
    1104          !!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed  
    1105 !!gm    A priori a better value should be something like : 
    1106 !!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)  
    1107 !!gm                     divided by the sum of the corresponding mask  
    1108 !!gm  
    1109 !!             
    1110          IF( .NOT.ln_sco ) THEN 
    1111    
    1112    !!gm  agree the JC comment  : this should be done in a much clear way 
    1113    
    1114    ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 
    1115    !     Set it to zero for the time being  
    1116    !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
    1117    !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
    1118    !              ENDIF 
    1119    !              zhf(:,:) = gdepw_0(:,:,jk+1) 
    1120             ! 
    1121          ELSE 
    1122             ! 
    1123             !zhf(:,:) = hbatf(:,:) 
    1124             DO_2D( 1, 0, 1, 0 ) 
    1125                zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
    1126                     &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
    1127                     &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
    1128                     &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
    1129             END_2D 
    1130          ENDIF 
    1131          ! 
    1132          DO jj = 1, jpjm1 
    1133             zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
    1134          END DO 
    1135          ! 
    1136          DO jk = 1, jpkm1 
    1137             DO jj = 1, jpjm1 
    1138                zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
    1139             END DO 
    1140          END DO 
    1141          CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
    1142          ! JC: TBC. hf should be greater than 0  
    1143          DO_2D( 1, 1, 1, 1 ) 
    1144             IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
    1145          END_2D 
    1146          zwz(:,:) = ff_f(:,:) * zwz(:,:) 
    11471135      END SELECT 
    11481136       
    11491137   END SUBROUTINE dyn_cor_2d_init 
    1150  
    11511138 
    11521139 
    … …  
    13421329   END SUBROUTINE wad_spg 
    13431330      
    1344  
    13451331 
    13461332   SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynvor.F90

    r14037 r14062  
    2121   !!             -   ! 2018-03  (G. Madec)  add two new schemes (ln_dynvor_enT and ln_dynvor_eet) 
    2222   !!             -   ! 2018-04  (G. Madec)  add pre-computed gradient for metric term calculation 
     23   !!            4.x  ! 2020-03  (G. Madec, A. Nasser)  make ln_dynvor_msk truly efficient on relative vorticity 
    2324   !!            4.2  ! 2020-12  (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) 
    2425   !!---------------------------------------------------------------------- 
    … …  
    2627   !!---------------------------------------------------------------------- 
    2728   !!   dyn_vor       : Update the momentum trend with the vorticity trend 
     29   !!       vor_enT   : energy conserving scheme at T-pt  (ln_dynvor_enT=T) 
     30   !!       vor_ene   : energy conserving scheme          (ln_dynvor_ene=T) 
    2831   !!       vor_ens   : enstrophy conserving scheme       (ln_dynvor_ens=T) 
    29    !!       vor_ene   : energy conserving scheme          (ln_dynvor_ene=T) 
    3032   !!       vor_een   : energy and enstrophy conserving   (ln_dynvor_een=T) 
     33   !!       vor_eeT   : energy conserving at T-pt         (ln_dynvor_eeT=T) 
    3134   !!   dyn_vor_init  : set and control of the different vorticity option 
    3235   !!---------------------------------------------------------------------- 
    … …  
    5861   LOGICAL, PUBLIC ::   ln_dynvor_eeT   !: t-point energy conserving scheme     (EET) 
    5962   LOGICAL, PUBLIC ::   ln_dynvor_een   !: energy & enstrophy conserving scheme (EEN) 
    60    INTEGER, PUBLIC ::      nn_een_e3f      !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    6163   LOGICAL, PUBLIC ::   ln_dynvor_mix   !: mixed scheme                         (MIX) 
    6264   LOGICAL, PUBLIC ::   ln_dynvor_msk   !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 
     65   INTEGER, PUBLIC ::   nn_e3f_typ      !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    6366 
    6467   INTEGER, PUBLIC ::   nvor_scheme     !: choice of the type of advection scheme 
    … …  
    8184   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2u_2        ! = di(e2u)/2          used in T-point metric term calculation 
    8285   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1v_2        ! = dj(e1v)/2           -        -      -       -  
    83    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2v_2e1e2f   ! = di(e2v)/(2*e1e2f)  used in F-point metric term calculation 
    84    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1u_2e1e2f   ! = dj(e1u)/(2*e1e2f)   -        -      -       -  
     86   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2v_2e1e2f   ! = di(e2u)/(2*e1e2f)  used in F-point metric term calculation 
     87   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1u_2e1e2f   ! = dj(e1v)/(2*e1e2f)   -        -      -       - 
     88   ! 
     89   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   e3f_0vor   ! e3f used in EEN, ENE and ENS cases (key_qco only) 
    8590    
    8691   REAL(wp) ::   r1_4  = 0.250_wp         ! =1/4 
    … …  
    235240      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    236241      REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars 
    237       REAL(wp), DIMENSION(jpi,jpj)       ::   zwx, zwy, zwt   ! 2D workspace 
    238       REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz             ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 
     242      REAL(wp), DIMENSION(jpi,jpj)     ::   zwx, zwy, zwt   ! 2D workspace 
     243      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zwz      ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    239244      !!---------------------------------------------------------------------- 
    240245      ! 
    … …  
    246251      ! 
    247252      ! 
    248       SELECT CASE( kvor )                 !==  volume weighted vorticity considered  ==! 
    249       CASE ( np_RVO )                           !* relative vorticity 
    250          DO jk = 1, jpkm1                                 ! Horizontal slab 
     253      SELECT CASE( kvor )                 !== relative vorticity considered  ==! 
     254      ! 
     255      CASE ( np_RVO , np_CRV )                  !* relative vorticity at f-point is used 
     256         ALLOCATE( zwz(jpi,jpj,jpk) ) 
     257         DO jk = 1, jpkm1                                ! Horizontal slab 
    251258            DO_2D( 1, 0, 1, 0 ) 
    252259               zwz(ji,jj,jk) = (  e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
    253260                  &             - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    254261            END_2D 
    255             IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
     262            IF( ln_dynvor_msk ) THEN                     ! mask relative vorticity  
    256263               DO_2D( 1, 0, 1, 0 ) 
    257264                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    … …  
    259266            ENDIF 
    260267         END DO 
    261  
    262268         CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    263  
    264       CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    265          DO jk = 1, jpkm1                                 ! Horizontal slab 
    266             DO_2D( 1, 0, 1, 0 )                          ! relative vorticity 
    267                zwz(ji,jj,jk) = (   e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)   & 
    268                   &              - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj) 
    269             END_2D 
    270             IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
    271                DO_2D( 1, 0, 1, 0 ) 
    272                   zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    273                END_2D 
    274             ENDIF 
    275          END DO 
    276  
    277          CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    278  
     269         ! 
    279270      END SELECT 
    280271 
    281272      !                                                ! =============== 
    282273      DO jk = 1, jpkm1                                 ! Horizontal slab 
    283       !                                                ! =============== 
    284  
     274         !                                             ! =============== 
     275         ! 
    285276         SELECT CASE( kvor )                 !==  volume weighted vorticity considered  ==! 
     277         ! 
    286278         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    287279            zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm) 
    288280         CASE ( np_RVO )                           !* relative vorticity 
    289281            DO_2D( 0, 1, 0, 1 ) 
    290                zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)   & 
    291                   &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 
    292                   &                  * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     282               zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)       & 
     283                  &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk)   )  & 
     284                  &              * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    293285            END_2D 
    294286         CASE ( np_MET )                           !* metric term 
    295287            DO_2D( 0, 1, 0, 1 ) 
    296                zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   & 
    297                   &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) & 
    298                   &             * e3t(ji,jj,jk,Kmm) 
     288               zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)       & 
     289                  &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   )   & 
     290                  &       * e3t(ji,jj,jk,Kmm) 
    299291            END_2D 
    300292         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    301293            DO_2D( 0, 1, 0, 1 ) 
    302                zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)    & 
    303                   &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) & 
    304                   &                                 * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     294               zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)        & 
     295                  &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  )   & 
     296                  &       * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    305297            END_2D 
    306298         CASE ( np_CME )                           !* Coriolis + metric 
    307299            DO_2D( 0, 1, 0, 1 ) 
    308                zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           & 
    309                     &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  & 
    310                     &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) & 
    311                     &          * e3t(ji,jj,jk,Kmm) 
     300               zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                               & 
     301                    &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)      & 
     302                    &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  )   & 
     303                    &     * e3t(ji,jj,jk,Kmm) 
    312304            END_2D 
    313305         CASE DEFAULT                                             ! error 
    314             CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
     306            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor') 
    315307         END SELECT 
    316308         ! 
    … …  
    328320      END DO                                           !   End of slab 
    329321      !                                                ! =============== 
     322      ! 
     323      SELECT CASE( kvor )        ! deallocate zwz if necessary 
     324      CASE ( np_RVO , np_CRV )   ;   DEALLOCATE( zwz ) 
     325      END SELECT 
     326      ! 
    330327   END SUBROUTINE vor_enT 
    331328 
    … …  
    358355      ! 
    359356      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    360       REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars 
     357      REAL(wp) ::   zx1, zy1, zx2, zy2, ze3f, zmsk   ! local scalars 
    361358      REAL(wp), DIMENSION(jpi,jpj) ::   zwx, zwy, zwz   ! 2D workspace 
    362359      !!---------------------------------------------------------------------- 
    … …  
    380377                  &          - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    381378            END_2D 
     379            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     380               DO_2D( 1, 0, 1, 0 ) 
     381                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
     382               END_2D 
     383            ENDIF 
    382384         CASE ( np_MET )                           !* metric term 
    383385            DO_2D( 1, 0, 1, 0 ) 
    … …  
    390392                  &                        - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    391393            END_2D 
     394            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity (NOT the Coriolis term) 
     395               DO_2D( 1, 0, 1, 0 ) 
     396                  zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 
     397               END_2D 
     398            ENDIF 
    392399         CASE ( np_CME )                           !* Coriolis + metric 
    393400            DO_2D( 1, 0, 1, 0 ) 
    … …  
    399406         END SELECT 
    400407         ! 
    401          IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    402             DO_2D( 1, 0, 1, 0 ) 
    403                zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
    404             END_2D 
    405          ENDIF 
    406  
    407          IF( ln_sco ) THEN 
    408             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    409             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    410             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    411          ELSE 
    412             zwx(:,:) = e2u(:,:) * pu(:,:,jk) 
    413             zwy(:,:) = e1v(:,:) * pv(:,:,jk) 
    414          ENDIF 
     408#if defined key_qco 
     409         DO_2D( 1, 0, 1, 0 )                 !==  potential vorticity  ==!   (key_qco) 
     410            zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 
     411         END_2D 
     412#else 
     413         SELECT CASE( nn_e3f_typ  )           !==  potential vorticity  ==! 
     414         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
     415            DO_2D( 1, 0, 1, 0 ) 
     416               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     417                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     418                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     419                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     420               IF( ze3f /= 0._wp ) THEN   ;   zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 
     421               ELSE                       ;   zwz(ji,jj) = 0._wp 
     422               ENDIF 
     423            END_2D 
     424         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
     425            DO_2D( 1, 0, 1, 0 ) 
     426               ze3f = (   e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     427                  &     + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     428                  &     + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     429                  &     + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)   ) 
     430               zmsk = (   tmask(ji,jj+1,jk)   + tmask(ji+1,jj+1,jk)   & 
     431                  &     + tmask(ji,jj  ,jk)   + tmask(ji+1,jj  ,jk)   ) 
     432               IF( ze3f /= 0._wp ) THEN   ;   zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 
     433               ELSE                       ;   zwz(ji,jj) = 0._wp 
     434               ENDIF 
     435            END_2D 
     436         END SELECT 
     437#endif 
     438         !                                   !==  horizontal fluxes  ==! 
     439         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     440         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
     441         ! 
    415442         !                                   !==  compute and add the vorticity term trend  =! 
    416443         DO_2D( 0, 0, 0, 0 ) 
    … …  
    455482      ! 
    456483      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    457       REAL(wp) ::   zuav, zvau   ! local scalars 
     484      REAL(wp) ::   zuav, zvau, ze3f, zmsk   ! local scalars 
    458485      REAL(wp), DIMENSION(jpi,jpj) ::   zwx, zwy, zwz, zww   ! 2D workspace 
    459486      !!---------------------------------------------------------------------- 
    … …  
    476503                  &          - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    477504            END_2D 
     505            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     506               DO_2D( 1, 0, 1, 0 ) 
     507                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
     508               END_2D 
     509            ENDIF 
    478510         CASE ( np_MET )                           !* metric term 
    479511            DO_2D( 1, 0, 1, 0 ) 
    … …  
    486518                  &                        - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    487519            END_2D 
     520            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity (NOT the Coriolis term) 
     521               DO_2D( 1, 0, 1, 0 ) 
     522                  zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 
     523               END_2D 
     524            ENDIF 
    488525         CASE ( np_CME )                           !* Coriolis + metric 
    489526            DO_2D( 1, 0, 1, 0 ) 
    … …  
    495532         END SELECT 
    496533         ! 
    497          IF( ln_dynvor_msk ) THEN           !==  mask/unmask vorticity ==! 
    498             DO_2D( 1, 0, 1, 0 ) 
    499                zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
    500             END_2D 
    501          ENDIF 
    502          ! 
    503          IF( ln_sco ) THEN                   !==  horizontal fluxes  ==! 
    504             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    505             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    506             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    507          ELSE 
    508             zwx(:,:) = e2u(:,:) * pu(:,:,jk) 
    509             zwy(:,:) = e1v(:,:) * pv(:,:,jk) 
    510          ENDIF 
     534         ! 
     535#if defined key_qco 
     536         DO_2D( 1, 0, 1, 0 )                 !==  potential vorticity  ==!   (key_qco) 
     537            zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 
     538         END_2D 
     539#else 
     540         SELECT CASE( nn_e3f_typ )           !==  potential vorticity  ==! 
     541         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
     542            DO_2D( 1, 0, 1, 0 ) 
     543               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     544                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     545                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     546                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     547               IF( ze3f /= 0._wp ) THEN   ;   zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 
     548               ELSE                       ;   zwz(ji,jj) = 0._wp 
     549               ENDIF 
     550            END_2D 
     551         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
     552            DO_2D( 1, 0, 1, 0 ) 
     553               ze3f = (   e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     554                  &     + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     555                  &     + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     556                  &     + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)   ) 
     557               zmsk = (   tmask(ji,jj+1,jk)   + tmask(ji+1,jj+1,jk)   & 
     558                  &     + tmask(ji,jj  ,jk)   + tmask(ji+1,jj  ,jk)   ) 
     559               IF( ze3f /= 0._wp ) THEN   ;   zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 
     560               ELSE                       ;   zwz(ji,jj) = 0._wp 
     561               ENDIF 
     562            END_2D 
     563         END SELECT 
     564#endif 
     565         !                                   !==  horizontal fluxes  ==! 
     566         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     567         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
     568         ! 
    511569         !                                   !==  compute and add the vorticity term trend  =! 
    512570         DO_2D( 0, 0, 0, 0 ) 
    … …  
    566624         !                                             ! =============== 
    567625         ! 
    568          SELECT CASE( nn_een_e3f )           ! == reciprocal of e3 at F-point 
     626#if defined key_qco 
     627         DO_2D( 1, 0, 1, 0 )                 ! == reciprocal of e3 at F-point (key_qco) 
     628            z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) 
     629         END_2D 
     630#else 
     631         SELECT CASE( nn_e3f_typ )           ! == reciprocal of e3 at F-point 
    569632         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    570633            DO_2D( 1, 0, 1, 0 ) 
    … …  
    590653            END_2D 
    591654         END SELECT 
     655#endif 
    592656         ! 
    593657         SELECT CASE( kvor )                 !==  vorticity considered  ==! 
     658         ! 
    594659         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    595660            DO_2D( 1, 0, 1, 0 ) 
    … …  
    601666                  &            - e1u(ji  ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) 
    602667            END_2D 
     668            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     669               DO_2D( 1, 0, 1, 0 ) 
     670                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     671               END_2D 
     672            ENDIF 
    603673         CASE ( np_MET )                           !* metric term 
    604674            DO_2D( 1, 0, 1, 0 ) 
    … …  
    612682                  &                           * r1_e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
    613683            END_2D 
     684            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     685               DO_2D( 1, 0, 1, 0 ) 
     686                  zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)  
     687               END_2D 
     688            ENDIF 
    614689         CASE ( np_CME )                           !* Coriolis + metric 
    615690            DO_2D( 1, 0, 1, 0 ) 
    … …  
    620695            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    621696         END SELECT 
    622          ! 
    623          IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    624             DO_2D( 1, 0, 1, 0 ) 
    625                zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    626             END_2D 
    627          ENDIF 
     697         !                                             ! =============== 
    628698      END DO                                           !   End of slab 
    629          ! 
     699      !                                                ! =============== 
     700      ! 
    630701      CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    631  
     702      ! 
     703      !                                                ! =============== 
    632704      DO jk = 1, jpkm1                                 ! Horizontal slab 
     705         !                                             ! =============== 
    633706         ! 
    634707         !                                   !==  horizontal fluxes  ==! 
    635708         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    636709         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    637  
     710         ! 
    638711         !                                   !==  compute and add the vorticity term trend  =! 
    639          jj = 2 
    640          ztne(1,:) = 0   ;   ztnw(1,:) = 0   ;   ztse(1,:) = 0   ;   ztsw(1,:) = 0 
    641          DO ji = 2, jpi          ! split in 2 parts due to vector opt. 
    642                ztne(ji,jj) = zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) 
    643                ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) 
    644                ztse(ji,jj) = zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) 
    645                ztsw(ji,jj) = zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) 
    646          END DO 
    647          DO jj = 3, jpj 
    648             DO ji = 2, jpi   ! vector opt. ok because we start at jj = 3 
    649                ztne(ji,jj) = zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) 
    650                ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) 
    651                ztse(ji,jj) = zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) 
    652                ztsw(ji,jj) = zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) 
    653             END DO 
    654          END DO 
     712         DO_2D( 0, 1, 0, 1 ) 
     713            ztne(ji,jj) = zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) 
     714            ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) 
     715            ztse(ji,jj) = zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) 
     716            ztsw(ji,jj) = zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) 
     717         END_2D 
     718         ! 
    655719         DO_2D( 0, 0, 0, 0 ) 
    656720            zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    … …  
    667731 
    668732 
    669  
    670733   SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    671734      !!---------------------------------------------------------------------- 
    … …  
    685748      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 
    686749      !!---------------------------------------------------------------------- 
    687       INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     750      INTEGER                         , INTENT(in   ) ::   kt               ! ocean time-step index 
    688751      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    689       INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    690       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
    691       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
     752      INTEGER                         , INTENT(in   ) ::   kvor             ! total, planetary, relative, or metric 
     753      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv           ! now velocities 
     754      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs   ! total v-trend 
    692755      ! 
    693756      INTEGER  ::   ji, jj, jk     ! dummy loop indices 
    … …  
    702765      IF( kt == nit000 ) THEN 
    703766         IF(lwp) WRITE(numout,*) 
    704          IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' 
     767         IF(lwp) WRITE(numout,*) 'dyn:vor_eeT : vorticity term: energy and enstrophy conserving scheme' 
    705768         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    706769      ENDIF 
    … …  
    722785                  &          * r1_e1e2f(ji,jj) 
    723786            END_2D 
     787            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     788               DO_2D( 1, 0, 1, 0 ) 
     789                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     790               END_2D 
     791            ENDIF 
    724792         CASE ( np_MET )                           !* metric term 
    725793            DO_2D( 1, 0, 1, 0 ) 
    … …  
    733801                  &                         * r1_e1e2f(ji,jj)    ) 
    734802            END_2D 
     803            IF( ln_dynvor_msk ) THEN                     ! mask the relative vorticity 
     804               DO_2D( 1, 0, 1, 0 ) 
     805                  zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)  
     806               END_2D 
     807            ENDIF 
    735808         CASE ( np_CME )                           !* Coriolis + metric 
    736809            DO_2D( 1, 0, 1, 0 ) 
    … …  
    742815         END SELECT 
    743816         ! 
    744          IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    745             DO_2D( 1, 0, 1, 0 ) 
    746                zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    747             END_2D 
    748          ENDIF 
    749       END DO 
     817         !                                             ! =============== 
     818      END DO                                           !   End of slab 
     819      !                                                ! =============== 
    750820      ! 
    751821      CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    752822      ! 
     823      !                                                ! =============== 
    753824      DO jk = 1, jpkm1                                 ! Horizontal slab 
    754  
    755       !                                   !==  horizontal fluxes  ==! 
     825         !                                             ! =============== 
     826         ! 
     827         !                                   !==  horizontal fluxes  ==! 
    756828         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    757829         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    758  
     830         ! 
    759831         !                                   !==  compute and add the vorticity term trend  =! 
    760          jj = 2 
    761          ztne(1,:) = 0   ;   ztnw(1,:) = 0   ;   ztse(1,:) = 0   ;   ztsw(1,:) = 0 
    762          DO ji = 2, jpi          ! split in 2 parts due to vector opt. 
    763                z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    764                ztne(ji,jj) = ( zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) ) * z1_e3t 
    765                ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) ) * z1_e3t 
    766                ztse(ji,jj) = ( zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 
    767                ztsw(ji,jj) = ( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) ) * z1_e3t 
    768          END DO 
    769          DO jj = 3, jpj 
    770             DO ji = 2, jpi   ! vector opt. ok because we start at jj = 3 
    771                z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    772                ztne(ji,jj) = ( zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) ) * z1_e3t 
    773                ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) ) * z1_e3t 
    774                ztse(ji,jj) = ( zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 
    775                ztsw(ji,jj) = ( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) ) * z1_e3t 
    776             END DO 
    777          END DO 
     832         DO_2D( 0, 1, 0, 1 ) 
     833            z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
     834            ztne(ji,jj) = ( zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) ) * z1_e3t 
     835            ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) ) * z1_e3t 
     836            ztse(ji,jj) = ( zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 
     837            ztsw(ji,jj) = ( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) ) * z1_e3t 
     838         END_2D 
     839         ! 
    778840         DO_2D( 0, 0, 0, 0 ) 
    779841            zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    … …  
    799861      INTEGER ::   ji, jj, jk    ! dummy loop indices 
    800862      INTEGER ::   ioptio, ios   ! local integer 
     863      REAL(wp) ::   zmsk    ! local scalars 
    801864      !! 
    802865      NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT,   & 
    803          &                 ln_dynvor_een, nn_een_e3f   , ln_dynvor_mix, ln_dynvor_msk 
     866         &                 ln_dynvor_een, nn_e3f_typ   , ln_dynvor_mix, ln_dynvor_msk 
    804867      !!---------------------------------------------------------------------- 
    805868      ! 
    … …  
    823886         WRITE(numout,*) '      energy conserving scheme  (een using e3t)      ln_dynvor_eeT = ', ln_dynvor_eeT 
    824887         WRITE(numout,*) '      enstrophy and energy conserving scheme         ln_dynvor_een = ', ln_dynvor_een 
    825          WRITE(numout,*) '         e3f = averaging /4 (=0) or /sum(tmask) (=1)    nn_een_e3f = ', nn_een_e3f 
     888         WRITE(numout,*) '         e3f = averaging /4 (=0) or /sum(tmask) (=1)    nn_e3f_typ = ', nn_e3f_typ 
    826889         WRITE(numout,*) '      mixed enstrophy/energy conserving scheme       ln_dynvor_mix = ', ln_dynvor_mix 
    827890         WRITE(numout,*) '      masked (=T) or unmasked(=F) vorticity          ln_dynvor_msk = ', ln_dynvor_msk 
    828891      ENDIF 
    829  
    830       IF( ln_dynvor_msk )   CALL ctl_stop( 'dyn_vor_init:   masked vorticity is not currently not available') 
    831892 
    832893!!gm  this should be removed when choosing a unique strategy for fmask at the coast 
    … …  
    891952         ! 
    892953      END SELECT 
    893        
     954#if defined key_qco 
     955      SELECT CASE( nvor_scheme )    ! qco case: pre-computed a specific e3f_0 for some vorticity schemes 
     956      CASE( np_ENS , np_ENE , np_EEN , np_MIX ) 
     957         ! 
     958         ALLOCATE( e3f_0vor(jpi,jpj,jpk) ) 
     959         ! 
     960         SELECT CASE( nn_e3f_typ ) 
     961         CASE ( 0 )                        ! original formulation  (masked averaging of e3t divided by 4) 
     962            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     963               e3f_0vor(ji,jj,jk) = (   e3t_0(ji  ,jj+1,jk)*tmask(ji  ,jj+1,jk)   & 
     964                  &                   + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
     965                  &                   + e3t_0(ji  ,jj  ,jk)*tmask(ji  ,jj  ,jk)   & 
     966                  &                   + e3t_0(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)   ) * 0.25_wp 
     967            END_3D 
     968         CASE ( 1 )                        ! new formulation  (masked averaging of e3t divided by the sum of mask) 
     969            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     970               zmsk = (tmask(ji,jj+1,jk) +tmask(ji+1,jj+1,jk)   & 
     971                  &  + tmask(ji,jj  ,jk) +tmask(ji+1,jj  ,jk)  ) 
     972               ! 
     973               IF( zmsk /= 0._wp ) THEN  
     974                  e3f_0vor(ji,jj,jk) = (   e3t_0(ji  ,jj+1,jk)*tmask(ji  ,jj+1,jk)   & 
     975                     &                   + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
     976                     &                   + e3t_0(ji  ,jj  ,jk)*tmask(ji  ,jj  ,jk)   & 
     977                     &                   + e3t_0(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)   ) / zmsk 
     978               ENDIF 
     979            END_3D 
     980         END SELECT 
     981         ! 
     982         CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) 
     983         !                                 ! insure e3f_0vor /= 0 
     984         WHERE( e3f_0vor(:,:,:) == 0._wp )   e3f_0vor(:,:,:) = e3f_0(:,:,:) 
     985         ! 
     986      END SELECT 
     987      ! 
     988#endif 
    894989      IF(lwp) THEN                   ! Print the choice 
    895990         WRITE(numout,*) 
    … …  
    898993         CASE( np_ENE )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at F-points) (ENE)' 
    899994         CASE( np_ENT )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at T-points) (ENT)' 
     995                              IF( ln_dynadv_vec )   CALL ctl_warn('dyn_vor_init: ENT scheme may not work in vector form') 
    900996         CASE( np_EET )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (EEN scheme using e3t) (EET)' 
    901997         CASE( np_EEN )   ;   WRITE(numout,*) '   ==>>>   energy and enstrophy conserving scheme (EEN)' 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/sshwzv.F90

    r14037 r14062  
    66   !! History :  3.1  !  2009-02  (G. Madec, M. Leclair)  Original code 
    77   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  modified LF-RA  
    8    !!             -   !  2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 
    9    !!             -   !  2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module 
    10    !!            3.3  !  2011-10  (M. Leclair) split former ssh_wzv routine and remove all vvl related work 
    11    !!            4.0  !  2018-12  (A. Coward) add mixed implicit/explicit advection 
    12    !!            4.1  !  2019-08  (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 
     8   !!             -   !  2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea)  Assimilation interface 
     9   !!             -   !  2010-09  (D.Storkey and E.O'Dea)  bug fixes for BDY module 
     10   !!            3.3  !  2011-10  (M. Leclair)  split former ssh_wzv routine and remove all vvl related work 
     11   !!            4.0  !  2018-12  (A. Coward)  add mixed implicit/explicit advection 
     12   !!            4.1  !  2019-08  (A. Coward, D. Storkey)  Rename ssh_nxt -> ssh_atf. Now only does time filtering. 
     13   !!             -   !  2020-08  (S. Techene, G. Madec)  add here ssh initiatlisation 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    1718   !!   ssh_atf       : time filter the ssh arrays 
    1819   !!   wzv           : compute now vertical velocity 
     20   !!   ssh_init_rst  : ssh set from restart or domcfg.nc file or usr_def_istat_ssh 
    1921   !!---------------------------------------------------------------------- 
    2022   USE oce            ! ocean dynamics and tracers variables 
    … …  
    4042   USE timing         ! Timing 
    4143   USE wet_dry        ! Wetting/Drying flux limiting 
    42  
     44   USE usrdef_istate, ONLY : usr_def_istate_ssh   ! user defined ssh initial state  
     45    
    4346   IMPLICIT NONE 
    4447   PRIVATE 
    4548 
    46    PUBLIC   ssh_nxt    ! called by step.F90 
    47    PUBLIC   wzv        ! called by step.F90 
    48    PUBLIC   wAimp      ! called by step.F90 
    49    PUBLIC   ssh_atf    ! called by step.F90 
     49   PUBLIC   ssh_nxt        ! called by step.F90 
     50   PUBLIC   wzv            ! called by step.F90 
     51   PUBLIC   wAimp          ! called by step.F90 
     52   PUBLIC   ssh_atf        ! called by step.F90 
     53   PUBLIC   ssh_init_rst   ! called by domain.F90 
    5054 
    5155   !! * Substitutions 
    5256#  include "do_loop_substitute.h90" 
    5357#  include "domzgr_substitute.h90" 
    54  
    5558   !!---------------------------------------------------------------------- 
    5659   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    299302         !                                                  ! filtered "now" field 
    300303         pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 
     304         ! 
    301305         IF( .NOT.ln_linssh ) THEN                          ! "now" <-- with forcing removed 
    302306            zcoef = rn_atfp * rn_Dt * r1_rho0 
    … …  
    307311 
    308312            ! ice sheet coupling 
    309             IF ( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1) pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 
     313            IF( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1 )   & 
     314               &   pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 
    310315 
    311316         ENDIF 
    312317      ENDIF 
    313318      ! 
    314       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' pssh(:,:,Kmm)  - : ', mask1=tmask ) 
     319      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' atf  - pssh(:,:,Kmm): ', mask1=tmask ) 
    315320      ! 
    316321      IF( ln_timing )   CALL timing_stop('ssh_atf') 
    … …  
    431436      ! 
    432437   END SUBROUTINE wAimp 
     438 
     439 
     440   SUBROUTINE ssh_init_rst( Kbb, Kmm, Kaa ) 
     441      !!--------------------------------------------------------------------- 
     442      !!                   ***  ROUTINE ssh_init_rst  *** 
     443      !! 
     444      !! ** Purpose :   ssh initialization of the sea surface height (ssh) 
     445      !! 
     446      !! ** Method  :   set ssh from restart or read configuration, or user_def 
     447      !!              * ln_rstart = T 
     448      !!                   USE of IOM library to read ssh in the restart file 
     449      !!                   Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T 
     450      !! 
     451      !!              * otherwise  
     452      !!                   call user defined ssh or 
     453      !!                   set to -ssh_ref in wet and drying case with domcfg.nc 
     454      !! 
     455      !!              NB: ssh_b/n are written by restart.F90 
     456      !!---------------------------------------------------------------------- 
     457      INTEGER, INTENT(in) ::   Kbb, Kmm, Kaa   ! ocean time level indices 
     458      ! 
     459      INTEGER ::   ji, jj, jk 
     460      !!---------------------------------------------------------------------- 
     461      ! 
     462      IF(lwp) THEN 
     463         WRITE(numout,*) 
     464         WRITE(numout,*) 'ssh_init_rst : ssh initialization' 
     465         WRITE(numout,*) '~~~~~~~~~~~~ ' 
     466      ENDIF 
     467      ! 
     468      !                            !=============================! 
     469      IF( ln_rstart ) THEN         !==  Read the restart file  ==! 
     470         !                         !=============================! 
     471         ! 
     472         !                                     !*  Read ssh at Kmm 
     473         IF(lwp) WRITE(numout,*) 
     474         IF(lwp) WRITE(numout,*)    '      Kmm sea surface height read in the restart file' 
     475         CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm) ) 
     476         ! 
     477         IF( l_1st_euler ) THEN                !* Euler at first time-step 
     478            IF(lwp) WRITE(numout,*) 
     479            IF(lwp) WRITE(numout,*) '      Euler first time step : ssh(Kbb) = ssh(Kmm)' 
     480            ssh(:,:,Kbb) = ssh(:,:,Kmm) 
     481            ! 
     482         ELSE                                  !* read ssh at Kbb 
     483            IF(lwp) WRITE(numout,*) 
     484            IF(lwp) WRITE(numout,*) '      Kbb sea surface height read in the restart file' 
     485            CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 
     486         ENDIF 
     487         !                         !============================! 
     488      ELSE                         !==  Initialize at "rest"  ==! 
     489         !                         !============================! 
     490         ! 
     491         IF(lwp) WRITE(numout,*) 
     492         IF(lwp) WRITE(numout,*)    '      initialization at rest' 
     493         ! 
     494         IF( ll_wd ) THEN                      !* wet and dry  
     495            ! 
     496            IF( ln_read_cfg  ) THEN                 ! read configuration : ssh_ref is read in domain_cfg file 
     497!!st  why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), 
     498!!st  since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm 
     499               ssh(:,:,Kbb) = -ssh_ref 
     500               ! 
     501               DO_2D( 1, 1, 1, 1 ) 
     502                  IF( ht_0(ji,jj)-ssh_ref <  rn_wdmin1 ) THEN   ! if total depth is less than min depth 
     503                     ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) 
     504                  ENDIF 
     505               END_2D 
     506            ELSE                                    ! user define configuration case   
     507               CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 
     508            ENDIF 
     509            ! 
     510         ELSE                                  !* user defined configuration 
     511            CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 
     512            ! 
     513         ENDIF 
     514         ! 
     515         ssh(:,:,Kmm) = ssh(:,:,Kbb)           !* set now values from to before ones 
     516         ssh(:,:,Kaa) = 0._wp  
     517      ENDIF 
     518      ! 
     519   END SUBROUTINE ssh_init_rst 
     520       
    433521   !!====================================================================== 
    434522END MODULE sshwzv 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/IOM/iom.F90

    r14044 r14062  
    174174         CALL set_grid( "V", glamv, gphiv, .FALSE., .FALSE. ) 
    175175         CALL set_grid( "W", glamt, gphit, .FALSE., .FALSE. ) 
     176         CALL set_grid( "F", glamf, gphif, .FALSE., .FALSE. ) 
    176177         CALL set_grid_znl( gphit ) 
    177178         ! 
    … …  
    180181            CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 
    181182            CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 
    182             CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 
     183            CALL iom_set_domain_attr("grid_W", area = REAL( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 
     184            CALL iom_set_domain_attr("grid_F", area = real( e1e2f(Nis0:Nie0, Njs0:Nje0), dp)) 
    183185            CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 
    184186            CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 
    185187            CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 
    186188            CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 
     189            CALL set_grid_bounds( "F", glamt, gphit, glamf, gphif ) 
    187190         ENDIF 
    188191      ENDIF 
    … …  
    191194         CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    192195         ! 
    193          CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. )  
    194          CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. )  
    195          CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. )  
    196          CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. )  
     196         CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 
     197         CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) 
     198         CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) 
     199         CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 
    197200         CALL set_grid_znl( gphit_crs ) 
    198201          ! 
    … …  
    217220         CALL iom_set_axis_attr(  "depthv", paxis = gdept_1d ) 
    218221         CALL iom_set_axis_attr(  "depthw", paxis = gdepw_1d ) 
     222          CALL iom_set_axis_attr(  "depthf", paxis = gdept_1d ) 
    219223 
    220224          ! ABL 
    … …  
    238242         CALL iom_set_axis_attr(  "depthv", bounds=zw_bnds ) 
    239243         CALL iom_set_axis_attr(  "depthw", bounds=zt_bnds ) 
     244          CALL iom_set_axis_attr(  "depthf", bounds=zw_bnds ) 
    240245 
    241246         ! ABL 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/IOM/restart.F90

    r14037 r14062  
    1111   !!            3.7  !  2014-01  (G. Madec) suppression of curl and hdiv from the restart 
    1212   !!             -   !  2014-12  (G. Madec) remove KPP scheme 
     13   !!            4.1  !  2020-11  (S. Techene, G. Madec)  move ssh initiatlisation in DYN/sshwzv:ssh_init_rst 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    139140      !! ** Method  :   Write in numrow when kt == nitrst in NetCDF 
    140141      !!              file, save fields which are necessary for restart 
     142      !! 
     143      !!                NB: ssh is written here (rst_write) 
     144      !!                    but is read or set in DYN/sshwzv:shh_init_rst 
    141145      !!---------------------------------------------------------------------- 
    142146      INTEGER, INTENT(in) ::   kt         ! ocean time-step 
    … …  
    233237      !!                   ***  ROUTINE rst_read  *** 
    234238      !!  
    235       !! ** Purpose :   Read files for NetCDF restart 
    236       !!  
    237       !! ** Method  :   Read in restart.nc file fields which are necessary for restart 
     239      !! ** Purpose :   Read velocity and T-S fields in the restart file 
     240      !!  
     241      !! ** Method  :   Read in restart.nc fields which are necessary for restart 
     242      !! 
     243      !!                NB: restart file openned           in DOM/domain.F90:dom_init 
     244      !!                    before field in restart tested in DOM/domain.F90:dom_init 
     245      !!                    (sshb) 
     246      !! 
     247      !!                NB: ssh is read or set in DYN/sshwzv:shh_init_rst 
     248      !!                    but is written     in IOM/restart:rst_write 
    238249      !!---------------------------------------------------------------------- 
    239250      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    240       REAL(wp) ::   zrdt 
    241251      INTEGER  ::   jk 
    242252      REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d 
    243253      !!---------------------------------------------------------------------- 
    244  
    245       CALL rst_read_open           ! open restart for reading (if not already opened) 
    246  
    247       ! Check dynamics and tracer time-step consistency and force Euler restart if changed 
    248       IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 )   THEN 
    249          CALL iom_get( numror, 'rdt', zrdt ) 
    250          IF( zrdt /= rn_Dt ) THEN 
    251             IF(lwp) WRITE( numout,*) 
    252             IF(lwp) WRITE( numout,*) 'rst_read:  rdt not equal to the read one' 
    253             IF(lwp) WRITE( numout,*) 
    254             IF(lwp) WRITE( numout,*) '      ==>>>   forced euler first time-step' 
    255             l_1st_euler =  .TRUE. 
    256          ENDIF 
    257       ENDIF 
    258  
     254      ! 
    259255      IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
    260        
    261       ! Diurnal DSST  
    262       IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst )  
     256      ! 
     257      !                             !*  Diurnal DSST  
     258      IF( ln_diurnal )   CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst )  
    263259      IF ( ln_diurnal_only ) THEN  
    264260         IF(lwp) WRITE( numout, * ) & 
    … …  
    269265         RETURN  
    270266      ENDIF   
    271  
    272       IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 
    273          ! before fields 
     267      ! 
     268      !                             !*  Read Kmm fields 
     269      IF(lwp) WRITE(numout,*)    '           Kmm u, v and T-S fields read in the restart file' 
     270      CALL iom_get( numror, jpdom_auto, 'un'     , uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
     271      CALL iom_get( numror, jpdom_auto, 'vn'     , vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
     272      CALL iom_get( numror, jpdom_auto, 'tn'     , ts(:,:,:,jp_tem,Kmm) ) 
     273      CALL iom_get( numror, jpdom_auto, 'sn'     , ts(:,:,:,jp_sal,Kmm) ) 
     274      ! 
     275      IF( l_1st_euler ) THEN        !*  Euler restart 
     276         IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields set to Kmm values' 
     277         ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm)         ! all before fields set to now values 
     278         uu(:,:,:  ,Kbb) = uu(:,:,:  ,Kmm) 
     279         vv(:,:,:  ,Kbb) = vv(:,:,:  ,Kmm) 
     280      ELSE                          !* Leap frog restart 
     281         IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields read in the restart file' 
    274282         CALL iom_get( numror, jpdom_auto, 'ub'     , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
    275283         CALL iom_get( numror, jpdom_auto, 'vb'     , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
    276284         CALL iom_get( numror, jpdom_auto, 'tb'     , ts(:,:,:,jp_tem,Kbb) ) 
    277285         CALL iom_get( numror, jpdom_auto, 'sb'     , ts(:,:,:,jp_sal,Kbb) ) 
    278          CALL iom_get( numror, jpdom_auto, 'sshb'   ,ssh(:,:         ,Kbb) ) 
    279       ELSE 
    280          l_1st_euler =  .TRUE.      ! before field not found, forced euler 1st time-step 
    281       ENDIF 
    282       ! 
    283       ! now fields 
    284       CALL iom_get( numror, jpdom_auto, 'un'     , uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
    285       CALL iom_get( numror, jpdom_auto, 'vn'     , vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
    286       CALL iom_get( numror, jpdom_auto, 'tn'     , ts(:,:,:,jp_tem,Kmm) ) 
    287       CALL iom_get( numror, jpdom_auto, 'sn'     , ts(:,:,:,jp_sal,Kmm) ) 
    288       CALL iom_get( numror, jpdom_auto, 'sshn'   ,ssh(:,:         ,Kmm) ) 
     286      ENDIF 
     287      ! 
    289288      IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
    290289         CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop )   ! now    potential density 
    … …  
    293292      ENDIF 
    294293      ! 
    295       IF( l_1st_euler ) THEN                                  ! Euler restart  
    296          ts   (:,:,:,:,Kbb) = ts   (:,:,:,:,Kmm)              ! all before fields set to now values 
    297          uu   (:,:,:  ,Kbb) = uu   (:,:,:  ,Kmm) 
    298          vv   (:,:,:  ,Kbb) = vv   (:,:,:  ,Kmm) 
    299          ssh  (:,:    ,Kbb) = ssh  (:,:    ,Kmm) 
    300       ENDIF 
    301       ! 
    302294   END SUBROUTINE rst_read 
    303295 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfcpl.F90

    r14037 r14062  
    1010 
    1111   !!---------------------------------------------------------------------- 
    12    !!   isfrst : read/write iceshelf variables in/from restart 
     12   !!   isfrst        : read/write iceshelf variables in/from restart 
    1313   !!---------------------------------------------------------------------- 
    14    USE isf_oce                          ! ice shelf variable 
     14   USE oce            ! ocean dynamics and tracers 
     15#if defined key_qco 
     16   USE domqco  , ONLY : dom_qco_zgr      ! vertical scale factor interpolation 
     17#else 
     18   USE domvvl  , ONLY : dom_vvl_zgr      ! vertical scale factor interpolation 
     19#endif 
     20   USE domutl  , ONLY : dom_ngb          ! find the closest grid point from a given lon/lat position 
     21   USE isf_oce        ! ice shelf variable 
    1522   USE isfutils, ONLY : debug 
    16    USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine 
    17 #if ! defined key_qco 
    18    USE domvvl  , ONLY: dom_vvl_zgr      ! vertical scale factor interpolation 
    19 #else 
    20    USE domqco   , ONLY: dom_qco_zgr      ! vertical scale factor interpolation 
    21 #endif 
    22    USE domutl  , ONLY: dom_ngb          ! find the closest grid point from a given lon/lat position 
    2323   ! 
    24    USE oce            ! ocean dynamics and tracers 
    2524   USE in_out_manager ! I/O manager 
    2625   USE iom            ! I/O library 
     26   USE lib_mpp , ONLY : mpp_sum, mpp_max ! mpp routine 
    2727   ! 
    2828   IMPLICIT NONE 
    … …  
    3434 
    3535   TYPE isfcons 
    36       INTEGER :: ii     ! i global 
    37       INTEGER :: jj     ! j global 
    38       INTEGER :: kk     ! k level 
    39       REAL(wp):: dvol   ! volume increment 
    40       REAL(wp):: dsal   ! salt increment 
    41       REAL(wp):: dtem   ! heat increment 
    42       REAL(wp):: lon    ! lon 
    43       REAL(wp):: lat    ! lat 
    44       INTEGER :: ngb    ! 0/1 (valid location or not (ie on halo or no neigbourg)) 
     36      INTEGER ::   ii     ! i global 
     37      INTEGER ::   jj     ! j global 
     38      INTEGER ::   kk     ! k level 
     39      REAL(wp)::   dvol   ! volume increment 
     40      REAL(wp)::   dsal   ! salt increment 
     41      REAL(wp)::   dtem   ! heat increment 
     42      REAL(wp)::   lon    ! lon 
     43      REAL(wp)::   lat    ! lat 
     44      INTEGER ::   ngb    ! 0/1 (valid location or not (ie on halo or no neigbourg)) 
    4545   END TYPE 
    4646   ! 
    … …  
    121121#endif  
    122122   END SUBROUTINE isfcpl_init 
    123    !  
    124    SUBROUTINE isfcpl_rst_write(kt, Kmm) 
     123 
     124    
     125   SUBROUTINE isfcpl_rst_write( kt, Kmm ) 
    125126      !!--------------------------------------------------------------------- 
    126127      !!                   ***  ROUTINE iscpl_rst_write  *** 
    … …  
    133134      !!---------------------------------------------------------------------- 
    134135      INTEGER :: jk                               ! loop index 
    135       REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw  ! e3t , e3u, e3v !!st patch to use substitution 
     136      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw  ! for qco substitution 
    136137      !!---------------------------------------------------------------------- 
    137138      ! 
    … …  
    153154   END SUBROUTINE isfcpl_rst_write 
    154155 
     156    
    155157   SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) 
    156158      !!----------------------------------------------------------------------  
    … …  
    184186         zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) 
    185187         DO_2D( 0, 0, 0, 0 ) 
    186             jip1=ji+1; jim1=ji-1; 
    187             jjp1=jj+1; jjm1=jj-1; 
     188            jip1=ji+1   ;   jim1=ji-1 
     189            jjp1=jj+1   ;   jjm1=jj-1 
    188190            ! 
    189191            zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1) 
    … …  
    191193            IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN 
    192194               ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj)     & 
    193                &           + zssh(jim1,jj)*zssmask0(jim1,jj)     & 
    194                &           + zssh(ji,jjp1)*zssmask0(ji,jjp1)     & 
    195                &           + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk 
     195                  &           + zssh(jim1,jj)*zssmask0(jim1,jj)     & 
     196                  &           + zssh(ji,jjp1)*zssmask0(ji,jjp1)     & 
     197                  &           + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk 
    196198               zssmask_b(ji,jj) = 1._wp 
    197199            ENDIF 
    … …  
    222224      CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 
    223225#else 
    224       CALL dom_qco_zgr(Kbb, Kmm, Kaa) 
     226      CALL dom_qco_zgr(Kbb, Kmm) 
    225227#endif 
    226228      ! 
    227229   END SUBROUTINE isfcpl_ssh 
    228230 
     231    
    229232   SUBROUTINE isfcpl_tra(Kmm) 
    230233      !!----------------------------------------------------------------------  
    … …  
    375378      !  
    376379   END SUBROUTINE isfcpl_tra 
     380    
    377381 
    378382   SUBROUTINE isfcpl_vol(Kmm) 
    … …  
    466470         risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) 
    467471      END DO 
    468  
     472      ! 
    469473   END SUBROUTINE isfcpl_vol 
    470474 
     475    
    471476   SUBROUTINE isfcpl_cons(Kmm) 
    472477      !!----------------------------------------------------------------------  

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfdynatf.F90

    r13237 r14062  
    1515   USE phycst , ONLY: r1_rho0         ! physical constant 
    1616   USE dom_oce                        ! time and space domain 
    17    USE oce, ONLY : ssh                ! sea-surface height !!st needed for substitution 
     17   USE oce, ONLY : ssh                ! sea-surface height for qco substitution 
    1818 
    1919   USE in_out_manager 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfrst.F90

    r14037 r14062  
    2828   !!---------------------------------------------------------------------- 
    2929CONTAINS 
    30    !  
    31    SUBROUTINE isfrst_read(cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) 
     30    
     31   SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) 
    3232      !!--------------------------------------------------------------------- 
    3333      !! 
    … …  
    5151      ! 
    5252      ! read restart 
    53       IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 
     53      IF( .NOT.l_1st_euler ) THEN 
    5454         IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
    5555         CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:)         )   ! before ice shelf melt 
    … …  
    6262      ! 
    6363   END SUBROUTINE isfrst_read 
    64    !  
    65    SUBROUTINE isfrst_write(kt, cdisf, ptsc, pfwf ) 
     64 
     65    
     66   SUBROUTINE isfrst_write( kt, cdisf, ptsc, pfwf ) 
    6667      !!--------------------------------------------------------------------- 
    6768      !! 
    … …  
    9495      ! 
    9596   END SUBROUTINE isfrst_write 
    96    ! 
     97    
     98   !!====================================================================== 
    9799END MODULE isfrst 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/LBC/mppini.F90

    r14037 r14062  
    217217      ! then we calculate them here now that we have our communicator size 
    218218      IF(lwp) THEN 
     219         WRITE(numout,*) 
    219220         WRITE(numout,*) 'mpp_init:' 
    220221         WRITE(numout,*) '~~~~~~~~ ' 
    221          WRITE(numout,*) 
    222222      ENDIF 
    223223      IF( jpni < 1 .OR. jpnj < 1 ) THEN 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/LDF/ldfdyn.F90

    r14037 r14062  
    3434   !                                    !!* Namelist namdyn_ldf : lateral mixing on momentum * 
    3535   LOGICAL , PUBLIC ::   ln_dynldf_OFF   !: No operator (i.e. no explicit diffusion) 
     36   INTEGER , PUBLIC ::   nn_dynldf_typ   !: operator type (0: div-rot ; 1: symmetric) 
    3637   LOGICAL , PUBLIC ::   ln_dynldf_lap   !: laplacian operator 
    3738   LOGICAL , PUBLIC ::   ln_dynldf_blp   !: bilaplacian operator 
    … …  
    5253 
    5354   !                                    !!* Parameter to control the type of lateral viscous operator 
    54    INTEGER, PARAMETER, PUBLIC ::   np_ERROR  =-10                       !: error in setting the operator 
    55    INTEGER, PARAMETER, PUBLIC ::   np_no_ldf = 00                       !: without operator (i.e. no lateral viscous trend) 
     55   INTEGER, PARAMETER, PUBLIC ::   np_ERROR   =-10                      !: error in setting the operator 
     56   INTEGER, PARAMETER, PUBLIC ::   np_no_ldf  = 00                      !: without operator (i.e. no lateral viscous trend) 
     57   ! 
     58   INTEGER, PARAMETER, PUBLIC ::   np_typ_rot = 0                       !: div-rot   operator 
     59   INTEGER, PARAMETER, PUBLIC ::   np_typ_sym = 1                       !: symmetric operator 
     60   ! 
    5661   !                          !!      laplacian     !    bilaplacian    ! 
    5762   INTEGER, PARAMETER, PUBLIC ::   np_lap    = 10   ,   np_blp    = 20  !: iso-level operator 
    … …  
    109114      CHARACTER(len=5) ::   cl_Units               ! units (m2/s or m4/s) 
    110115      !! 
    111       NAMELIST/namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp,   &   ! type of operator 
    112          &                 ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso,   &   ! acting direction of the operator 
    113          &                 nn_ahm_ijk_t , rn_Uv    , rn_Lv,   rn_ahm_b,   &   ! lateral eddy coefficient 
    114          &                 rn_csmc      , rn_minfac    , rn_maxfac            ! Smagorinsky settings 
     116      NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp,   &   ! type of operator 
     117         &                 ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso,                  &   ! acting direction of the operator 
     118         &                 nn_ahm_ijk_t , rn_Uv        , rn_Lv        ,   rn_ahm_b,      &   ! lateral eddy coefficient 
     119         &                 rn_csmc      , rn_minfac    , rn_maxfac                           ! Smagorinsky settings 
    115120      !!---------------------------------------------------------------------- 
    116121      ! 
    … …  
    130135         WRITE(numout,*) '      type :' 
    131136         WRITE(numout,*) '         no explicit diffusion                ln_dynldf_OFF = ', ln_dynldf_OFF 
     137         WRITE(numout,*) '         type of operator (div-rot or sym)    nn_dynldf_typ = ', nn_dynldf_typ 
    132138         WRITE(numout,*) '         laplacian operator                   ln_dynldf_lap = ', ln_dynldf_lap 
    133139         WRITE(numout,*) '         bilaplacian operator                 ln_dynldf_blp = ', ln_dynldf_blp 
    … …  
    147153         WRITE(numout,*) '         Smagorinsky coefficient              rn_csmc       = ', rn_csmc 
    148154         WRITE(numout,*) '         factor multiplier for eddy visc.' 
    149          WRITE(numout,*) '            lower limit (default 1.0)         rn_minfac    = ', rn_minfac 
    150          WRITE(numout,*) '            upper limit (default 1.0)         rn_maxfac    = ', rn_maxfac 
     155         WRITE(numout,*) '            lower limit (default 1.0)         rn_minfac     = ', rn_minfac 
     156         WRITE(numout,*) '            upper limit (default 1.0)         rn_maxfac     = ', rn_maxfac 
    151157      ENDIF 
    152158 
    … …  
    160166      IF( ln_dynldf_lap ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF 
    161167      IF( ln_dynldf_blp ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF 
    162       IF( ioptio /= 1   )   CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 
     168      IF( ioptio /= 1   )   CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 
    163169      ! 
    164170      IF(.NOT.ln_dynldf_OFF ) THEN     !==  direction ==>> type of operator  ==! 
     171         ! 
     172         SELECT CASE( nn_dynldf_typ )  ! div-rot or symmetric 
     173         CASE( np_typ_rot )   ;   IF(lwp)   WRITE(numout,*) '   ==>>>   use div-rot   operator ' 
     174         CASE( np_typ_sym )   ;   IF(lwp)   WRITE(numout,*) '   ==>>>   use symmetric operator ' 
     175         CASE DEFAULT                                     ! error 
     176            CALL ctl_stop('ldf_dyn_init: wrong value for nn_dynldf_typ (0 or 1)'  ) 
     177         END SELECT 
     178         ! 
    165179         ioptio = 0 
    166180         IF( ln_dynldf_lev )   ioptio = ioptio + 1 
    167181         IF( ln_dynldf_hor )   ioptio = ioptio + 1 
    168182         IF( ln_dynldf_iso )   ioptio = ioptio + 1 
    169          IF( ioptio /= 1   )   CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' ) 
     183         IF( ioptio /= 1   )   CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 direction options (level/hor/iso)' ) 
    170184         ! 
    171185         !                             ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/diaobs.F90

    r13216 r14062  
    5757   PUBLIC calc_date        ! Compute the date of a timestep 
    5858 
    59    LOGICAL, PUBLIC :: ln_diaobs          !: Logical switch for the obs operator 
    60    LOGICAL         :: ln_sstnight        !  Logical switch for night mean SST obs 
    61    LOGICAL         :: ln_sla_fp_indegs   !  T=> SLA obs footprint size specified in degrees, F=> in metres 
    62    LOGICAL         :: ln_sst_fp_indegs   !  T=> SST obs footprint size specified in degrees, F=> in metres 
    63    LOGICAL         :: ln_sss_fp_indegs   !  T=> SSS obs footprint size specified in degrees, F=> in metres 
    64    LOGICAL         :: ln_sic_fp_indegs   !  T=> sea-ice obs footprint size specified in degrees, F=> in metres 
    65  
    66    REAL(wp) ::   rn_sla_avglamscl   ! E/W diameter of SLA observation footprint (metres) 
    67    REAL(wp) ::   rn_sla_avgphiscl   ! N/S diameter of SLA observation footprint (metres) 
    68    REAL(wp) ::   rn_sst_avglamscl   ! E/W diameter of SST observation footprint (metres) 
    69    REAL(wp) ::   rn_sst_avgphiscl   ! N/S diameter of SST observation footprint (metres) 
    70    REAL(wp) ::   rn_sss_avglamscl   ! E/W diameter of SSS observation footprint (metres) 
    71    REAL(wp) ::   rn_sss_avgphiscl   ! N/S diameter of SSS observation footprint (metres) 
    72    REAL(wp) ::   rn_sic_avglamscl   ! E/W diameter of sea-ice observation footprint (metres) 
    73    REAL(wp) ::   rn_sic_avgphiscl   ! N/S diameter of sea-ice observation footprint (metres) 
    74  
    75    INTEGER :: nn_1dint       ! Vertical interpolation method 
    76    INTEGER :: nn_2dint       ! Default horizontal interpolation method 
    77    INTEGER :: nn_2dint_sla   ! SLA horizontal interpolation method  
    78    INTEGER :: nn_2dint_sst   ! SST horizontal interpolation method  
    79    INTEGER :: nn_2dint_sss   ! SSS horizontal interpolation method  
    80    INTEGER :: nn_2dint_sic   ! Seaice horizontal interpolation method  
     59   LOGICAL, PUBLIC :: ln_diaobs            !: Logical switch for the obs operator 
     60   LOGICAL         :: ln_sstnight          !  Logical switch for night mean SST obs 
     61   LOGICAL         :: ln_default_fp_indegs !  T=> Default obs footprint size specified in degrees, F=> in metres 
     62   LOGICAL         :: ln_sla_fp_indegs     !  T=> SLA obs footprint size specified in degrees, F=> in metres 
     63   LOGICAL         :: ln_sst_fp_indegs     !  T=> SST obs footprint size specified in degrees, F=> in metres 
     64   LOGICAL         :: ln_sss_fp_indegs     !  T=> SSS obs footprint size specified in degrees, F=> in metres 
     65   LOGICAL         :: ln_sic_fp_indegs     !  T=> sea-ice obs footprint size specified in degrees, F=> in metres 
     66 
     67   REAL(wp) ::   rn_default_avglamscl      ! E/W diameter of SLA observation footprint (metres) 
     68   REAL(wp) ::   rn_default_avgphiscl      ! N/S diameter of SLA observation footprint (metre 
     69   REAL(wp) ::   rn_sla_avglamscl          ! E/W diameter of SLA observation footprint (metres) 
     70   REAL(wp) ::   rn_sla_avgphiscl          ! N/S diameter of SLA observation footprint (metres) 
     71   REAL(wp) ::   rn_sst_avglamscl          ! E/W diameter of SST observation footprint (metres) 
     72   REAL(wp) ::   rn_sst_avgphiscl          ! N/S diameter of SST observation footprint (metres) 
     73   REAL(wp) ::   rn_sss_avglamscl          ! E/W diameter of SSS observation footprint (metres) 
     74   REAL(wp) ::   rn_sss_avgphiscl          ! N/S diameter of SSS observation footprint (metres) 
     75   REAL(wp) ::   rn_sic_avglamscl          ! E/W diameter of sea-ice observation footprint (metres) 
     76   REAL(wp) ::   rn_sic_avgphiscl          ! N/S diameter of sea-ice observation footprint (metres) 
     77 
     78   INTEGER :: nn_1dint                     ! Vertical interpolation method 
     79   INTEGER :: nn_2dint_default             ! Default horizontal interpolation method 
     80   INTEGER :: nn_2dint_sla                 ! SLA horizontal interpolation method  
     81   INTEGER :: nn_2dint_sst                 ! SST horizontal interpolation method  
     82   INTEGER :: nn_2dint_sss                 ! SSS horizontal interpolation method  
     83   INTEGER :: nn_2dint_sic                 ! Seaice horizontal interpolation method  
    8184   INTEGER, DIMENSION(imaxavtypes) ::   nn_profdavtypes   ! Profile data types representing a daily average 
    8285   INTEGER :: nproftypes     ! Number of profile obs types 
    … …  
    9497   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdataqc   !: Profile data after quality control 
    9598 
    96    CHARACTER(len=lca), PUBLIC, DIMENSION(:), ALLOCATABLE ::   cobstypesprof, cobstypessurf   !: Profile & surface obs types 
     99   CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE ::   cobstypesprof, cobstypessurf   !: Profile & surface obs types 
    97100 
    98101   !!---------------------------------------------------------------------- 
    … …  
    121124      INTEGER :: jvar            ! Counter for variables 
    122125      INTEGER :: jfile           ! Counter for files 
    123       INTEGER :: jnumsstbias 
     126      INTEGER :: jnumsstbias     ! Number of SST bias files to read and apply 
     127      INTEGER :: n2dint_type     ! Local version of nn_2dint* 
    124128      ! 
    125129      CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 
    … …  
    130134         & cn_sicfbfiles, &      ! Seaice concentration input filenames 
    131135         & cn_velfbfiles, &      ! Velocity profile input filenames 
    132          & cn_sstbiasfiles      ! SST bias input filenames 
     136         & cn_sstbiasfiles       ! SST bias input filenames 
    133137      CHARACTER(LEN=128) :: & 
    134138         & cn_altbiasfile        ! Altimeter bias input filename 
    … …  
    136140         & clproffiles, &        ! Profile filenames 
    137141         & clsurffiles           ! Surface filenames 
     142      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & 
     143         & clvars                ! Expected variable names 
    138144         ! 
    139145      LOGICAL :: ln_t3d          ! Logical switch for temperature profiles 
    … …  
    150156      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs 
    151157      LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. 
    152       LOGICAL :: llvar1          ! Logical for profile variable 1 
    153       LOGICAL :: llvar2          ! Logical for profile variable 1 
     158      LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 
     159      LOGICAL :: ltype_night     ! Local version of ln_sstnight (false for other variables) 
     160      LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar   ! Logical for profile variable read 
    154161      LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 
    155162      ! 
    156       REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS 
    157       REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS 
    158       REAL(wp), DIMENSION(jpi,jpj)     ::   zglam1, zglam2   ! Model longitudes for profile variable 1 & 2 
    159       REAL(wp), DIMENSION(jpi,jpj)     ::   zgphi1, zgphi2   ! Model latitudes  for profile variable 1 & 2 
    160       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask1, zmask2   ! Model land/sea mask associated with variable 1 & 2 
     163      REAL(dp) :: rn_dobsini      ! Obs window start date YYYYMMDD.HHMMSS 
     164      REAL(dp) :: rn_dobsend      ! Obs window end date   YYYYMMDD.HHMMSS 
     165      REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 
     166      REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 
     167      REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE :: zglam   ! Model longitudes for profile variables 
     168      REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE :: zgphi   ! Model latitudes  for profile variables 
     169      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask   ! Model land/sea mask associated with variables 
    161170      !! 
    162171      NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla,              & 
    … …  
    165174         &            ln_grid_global, ln_grid_search_lookup,          & 
    166175         &            ln_ignmis, ln_s_at_t, ln_bound_reject,          & 
    167          &            ln_sstnight,                                    & 
     176         &            ln_sstnight, ln_default_fp_indegs,              & 
    168177         &            ln_sla_fp_indegs, ln_sst_fp_indegs,             & 
    169178         &            ln_sss_fp_indegs, ln_sic_fp_indegs,             & 
    … …  
    174183         &            cn_gridsearchfile, rn_gridsearchres,            & 
    175184         &            rn_dobsini, rn_dobsend,                         & 
     185         &            rn_default_avglamscl, rn_default_avgphiscl,     & 
    176186         &            rn_sla_avglamscl, rn_sla_avgphiscl,             & 
    177187         &            rn_sst_avglamscl, rn_sst_avgphiscl,             & 
    178188         &            rn_sss_avglamscl, rn_sss_avgphiscl,             & 
    179189         &            rn_sic_avglamscl, rn_sic_avgphiscl,             & 
    180          &            nn_1dint, nn_2dint,                             & 
     190         &            nn_1dint, nn_2dint_default,                     & 
    181191         &            nn_2dint_sla, nn_2dint_sst,                     & 
    182192         &            nn_2dint_sss, nn_2dint_sic,                     & 
    … …  
    234244         WRITE(numout,*) '      Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend 
    235245         WRITE(numout,*) '      Type of vertical interpolation method                  nn_1dint = ', nn_1dint 
    236          WRITE(numout,*) '      Type of horizontal interpolation method                nn_2dint = ', nn_2dint 
     246         WRITE(numout,*) '      Default horizontal interpolation method        nn_2dint_default = ', nn_2dint_default 
     247         WRITE(numout,*) '      Type of horizontal interpolation method for SLA    nn_2dint_sla = ', nn_2dint_sla 
     248         WRITE(numout,*) '      Type of horizontal interpolation method for SST    nn_2dint_sst = ', nn_2dint_sst 
     249         WRITE(numout,*) '      Type of horizontal interpolation method for SSS    nn_2dint_sss = ', nn_2dint_sss         
     250         WRITE(numout,*) '      Type of horizontal interpolation method for SIC    nn_2dint_sic = ', nn_2dint_sic 
     251         WRITE(numout,*) '      Default E/W diameter of obs footprint      rn_default_avglamscl = ', rn_default_avglamscl 
     252         WRITE(numout,*) '      Default N/S diameter of obs footprint      rn_default_avgphiscl = ', rn_default_avgphiscl 
     253         WRITE(numout,*) '      Default obs footprint in deg [T] or m [F]  ln_default_fp_indegs = ', ln_default_fp_indegs 
     254         WRITE(numout,*) '      SLA E/W diameter of obs footprint              rn_sla_avglamscl = ', rn_sla_avglamscl 
     255         WRITE(numout,*) '      SLA N/S diameter of obs footprint              rn_sla_avgphiscl = ', rn_sla_avgphiscl 
     256         WRITE(numout,*) '      SLA obs footprint in deg [T] or m [F]          ln_sla_fp_indegs = ', ln_sla_fp_indegs 
     257         WRITE(numout,*) '      SST E/W diameter of obs footprint              rn_sst_avglamscl = ', rn_sst_avglamscl 
     258         WRITE(numout,*) '      SST N/S diameter of obs footprint              rn_sst_avgphiscl = ', rn_sst_avgphiscl 
     259         WRITE(numout,*) '      SST obs footprint in deg [T] or m [F]          ln_sst_fp_indegs = ', ln_sst_fp_indegs 
     260         WRITE(numout,*) '      SIC E/W diameter of obs footprint              rn_sic_avglamscl = ', rn_sic_avglamscl 
     261         WRITE(numout,*) '      SIC N/S diameter of obs footprint              rn_sic_avgphiscl = ', rn_sic_avgphiscl 
     262         WRITE(numout,*) '      SIC obs footprint in deg [T] or m [F]          ln_sic_fp_indegs = ', ln_sic_fp_indegs 
    237263         WRITE(numout,*) '      Rejection of observations near land switch               ln_nea = ', ln_nea 
    238264         WRITE(numout,*) '      Rejection of obs near open bdys                 ln_bound_reject = ', ln_bound_reject 
    … …  
    278304         IF( ln_t3d .OR. ln_s3d ) THEN 
    279305            jtype = jtype + 1 
    280             CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof  ', & 
    281                &                   cn_profbfiles, ifilesprof, cobstypesprof, clproffiles ) 
     306            cobstypesprof(jtype) = 'prof' 
     307            clproffiles(jtype,:) = cn_profbfiles 
    282308         ENDIF 
    283309         IF( ln_vel3d ) THEN 
    284310            jtype = jtype + 1 
    285             CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel   ', & 
    286                &                   cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles ) 
     311            cobstypesprof(jtype) = 'vel' 
     312            clproffiles(jtype,:) = cn_velfbfiles 
    287313         ENDIF 
     314         ! 
     315         CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 
    288316         ! 
    289317      ENDIF 
    … …  
    303331         IF( ln_sla ) THEN 
    304332            jtype = jtype + 1 
    305             CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla   ', & 
    306                &                   cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 
    307             CALL obs_setinterpopts( nsurftypes, jtype, 'sla   ',      & 
    308                &                  nn_2dint, nn_2dint_sla,             & 
    309                &                  rn_sla_avglamscl, rn_sla_avgphiscl, & 
    310                &                  ln_sla_fp_indegs, .FALSE.,          & 
    311                &                  n2dintsurf, zavglamscl, zavgphiscl, & 
    312                &                  lfpindegs, llnightav ) 
     333            cobstypessurf(jtype) = 'sla' 
     334            clsurffiles(jtype,:) = cn_slafbfiles 
    313335         ENDIF 
    314336         IF( ln_sst ) THEN 
    315337            jtype = jtype + 1 
    316             CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst   ', & 
    317                &                   cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 
    318             CALL obs_setinterpopts( nsurftypes, jtype, 'sst   ',      & 
    319                &                  nn_2dint, nn_2dint_sst,             & 
    320                &                  rn_sst_avglamscl, rn_sst_avgphiscl, & 
    321                &                  ln_sst_fp_indegs, ln_sstnight,      & 
    322                &                  n2dintsurf, zavglamscl, zavgphiscl, & 
    323                &                  lfpindegs, llnightav ) 
     338            cobstypessurf(jtype) = 'sst' 
     339            clsurffiles(jtype,:) = cn_sstfbfiles 
    324340         ENDIF 
    325341#if defined key_si3 || defined key_cice 
    326342         IF( ln_sic ) THEN 
    327343            jtype = jtype + 1 
    328             CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic   ', & 
    329                &                   cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 
    330             CALL obs_setinterpopts( nsurftypes, jtype, 'sic   ',      & 
    331                &                  nn_2dint, nn_2dint_sic,             & 
    332                &                  rn_sic_avglamscl, rn_sic_avgphiscl, & 
    333                &                  ln_sic_fp_indegs, .FALSE.,          & 
    334                &                  n2dintsurf, zavglamscl, zavgphiscl, & 
    335                &                  lfpindegs, llnightav ) 
     344            cobstypessurf(jtype) = 'sic' 
     345            clsurffiles(jtype,:) = cn_sicfbfiles 
    336346         ENDIF 
    337347#endif 
    338348         IF( ln_sss ) THEN 
    339349            jtype = jtype + 1 
    340             CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss   ', & 
    341                &                   cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 
    342             CALL obs_setinterpopts( nsurftypes, jtype, 'sss   ',      & 
    343                &                  nn_2dint, nn_2dint_sss,             & 
    344                &                  rn_sss_avglamscl, rn_sss_avgphiscl, & 
    345                &                  ln_sss_fp_indegs, .FALSE.,          & 
    346                &                  n2dintsurf, zavglamscl, zavgphiscl, & 
    347                &                  lfpindegs, llnightav ) 
     350            cobstypessurf(jtype) = 'sss' 
     351            clsurffiles(jtype,:) = cn_sssfbfiles 
    348352         ENDIF 
     353         ! 
     354         CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 
     355 
     356         DO jtype = 1, nsurftypes 
     357 
     358            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     359               IF ( nn_2dint_sla == -1 ) THEN 
     360                  n2dint_type  = nn_2dint_default 
     361               ELSE 
     362                  n2dint_type  = nn_2dint_sla 
     363               ENDIF 
     364               ztype_avglamscl = rn_sla_avglamscl 
     365               ztype_avgphiscl = rn_sla_avgphiscl 
     366               ltype_fp_indegs = ln_sla_fp_indegs 
     367               ltype_night     = .FALSE. 
     368            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 
     369               IF ( nn_2dint_sst == -1 ) THEN 
     370                  n2dint_type  = nn_2dint_default 
     371               ELSE 
     372                  n2dint_type  = nn_2dint_sst 
     373               ENDIF 
     374               ztype_avglamscl = rn_sst_avglamscl 
     375               ztype_avgphiscl = rn_sst_avgphiscl 
     376               ltype_fp_indegs = ln_sst_fp_indegs 
     377               ltype_night     = ln_sstnight 
     378            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 
     379               IF ( nn_2dint_sic == -1 ) THEN 
     380                  n2dint_type  = nn_2dint_default 
     381               ELSE 
     382                  n2dint_type  = nn_2dint_sic 
     383               ENDIF 
     384               ztype_avglamscl = rn_sic_avglamscl 
     385               ztype_avgphiscl = rn_sic_avgphiscl 
     386               ltype_fp_indegs = ln_sic_fp_indegs 
     387               ltype_night     = .FALSE. 
     388            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 
     389               IF ( nn_2dint_sss == -1 ) THEN 
     390                  n2dint_type  = nn_2dint_default 
     391               ELSE 
     392                  n2dint_type  = nn_2dint_sss 
     393               ENDIF 
     394               ztype_avglamscl = rn_sss_avglamscl 
     395               ztype_avgphiscl = rn_sss_avgphiscl 
     396               ltype_fp_indegs = ln_sss_fp_indegs 
     397               ltype_night     = .FALSE. 
     398            ELSE 
     399               n2dint_type     = nn_2dint_default 
     400               ztype_avglamscl = rn_default_avglamscl 
     401               ztype_avgphiscl = rn_default_avgphiscl 
     402               ltype_fp_indegs = ln_default_fp_indegs 
     403               ltype_night     = .FALSE. 
     404            ENDIF 
     405             
     406            CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 
     407               &                    nn_2dint_default, n2dint_type,                 & 
     408               &                    ztype_avglamscl, ztype_avgphiscl,              & 
     409               &                    ltype_fp_indegs, ltype_night,                  & 
     410               &                    n2dintsurf, zavglamscl, zavgphiscl,            & 
     411               &                    lfpindegs, llnightav ) 
     412 
     413         END DO 
    349414         ! 
    350415      ENDIF 
    … …  
    368433      ENDIF 
    369434      ! 
    370       IF( nn_2dint < 0  .OR.  nn_2dint > 6  ) THEN 
    371          CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available') 
     435      IF( nn_2dint_default < 0  .OR.  nn_2dint_default > 6  ) THEN 
     436         CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') 
    372437      ENDIF 
    373438      ! 
    … …  
    388453         DO jtype = 1, nproftypes 
    389454            ! 
    390             nvarsprof(jtype) = 2 
    391455            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 
    392                nextrprof(jtype) = 1 
    393                llvar1 = ln_t3d 
    394                llvar2 = ln_s3d 
    395                zglam1 = glamt 
    396                zgphi1 = gphit 
    397                zmask1 = tmask 
    398                zglam2 = glamt 
    399                zgphi2 = gphit 
    400                zmask2 = tmask 
    401             ENDIF 
    402             IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN 
     456               nvarsprof(jtype) = 2 
     457               nextrprof(jtype) = 1              
     458               ALLOCATE( llvar (nvarsprof(jtype)) ) 
     459               ALLOCATE( clvars(nvarsprof(jtype)) ) 
     460               ALLOCATE( zglam(jpi, jpj,      nvarsprof(jtype)) ) 
     461               ALLOCATE( zgphi(jpi, jpj,      nvarsprof(jtype)) ) 
     462               ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 
     463               llvar(1)       = ln_t3d 
     464               llvar(2)       = ln_s3d 
     465               clvars(1)      = 'POTM' 
     466               clvars(2)      = 'PSAL' 
     467               zglam(:,:,1)   = glamt(:,:) 
     468               zglam(:,:,2)   = glamt(:,:) 
     469               zgphi(:,:,1)   = gphit(:,:) 
     470               zgphi(:,:,2)   = gphit(:,:) 
     471               zmask(:,:,:,1) = tmask(:,:,:) 
     472               zmask(:,:,:,2) = tmask(:,:,:) 
     473            ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN 
     474               nvarsprof(jtype) = 2 
    403475               nextrprof(jtype) = 2 
    404                llvar1 = ln_vel3d 
    405                llvar2 = ln_vel3d 
    406                zglam1 = glamu 
    407                zgphi1 = gphiu 
    408                zmask1 = umask 
    409                zglam2 = glamv 
    410                zgphi2 = gphiv 
    411                zmask2 = vmask 
     476               ALLOCATE( llvar (nvarsprof(jtype)) ) 
     477               ALLOCATE( clvars(nvarsprof(jtype)) ) 
     478               ALLOCATE( zglam(jpi, jpj,      nvarsprof(jtype)) ) 
     479               ALLOCATE( zgphi(jpi, jpj,      nvarsprof(jtype)) ) 
     480               ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 
     481               llvar(1)       = ln_vel3d 
     482               llvar(2)       = ln_vel3d 
     483               clvars(1)      = 'UVEL' 
     484               clvars(2)      = 'VVEL' 
     485               zglam(:,:,1)   = glamu(:,:) 
     486               zglam(:,:,2)   = glamv(:,:) 
     487               zgphi(:,:,1)   = gphiu(:,:) 
     488               zgphi(:,:,2)   = gphiv(:,:) 
     489               zmask(:,:,:,1) = umask(:,:,:) 
     490               zmask(:,:,:,2) = vmask(:,:,:) 
     491            ELSE 
     492               nvarsprof(jtype) = 1 
     493               nextrprof(jtype) = 0 
     494               ALLOCATE( llvar (nvarsprof(jtype)) ) 
     495               ALLOCATE( clvars(nvarsprof(jtype)) ) 
     496               ALLOCATE( zglam(jpi, jpj,      nvarsprof(jtype)) ) 
     497               ALLOCATE( zgphi(jpi, jpj,      nvarsprof(jtype)) ) 
     498               ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 
     499               llvar(1)       = .TRUE. 
     500               zglam(:,:,1)   = glamt(:,:) 
     501               zgphi(:,:,1)   = gphit(:,:) 
     502               zmask(:,:,:,1) = tmask(:,:,:) 
    412503            ENDIF 
    413504            ! 
    … …  
    416507               &               clproffiles(jtype,1:ifilesprof(jtype)), & 
    417508               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 
    418                &               rn_dobsini, rn_dobsend, llvar1, llvar2, & 
    419                &               ln_ignmis, ln_s_at_t, .FALSE., & 
     509               &               rn_dobsini, rn_dobsend, llvar, & 
     510               &               ln_ignmis, ln_s_at_t, .FALSE., clvars, & 
    420511               &               kdailyavtypes = nn_profdavtypes ) 
    421512               ! 
    … …  
    425516            ! 
    426517            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 
    427                &               llvar1, llvar2, & 
     518               &               llvar, & 
    428519               &               jpi, jpj, jpk, & 
    429                &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & 
     520               &               zmask, zglam, zgphi, & 
    430521               &               ln_nea, ln_bound_reject, Kmm, & 
    431522               &               kdailyavtypes = nn_profdavtypes ) 
     523            ! 
     524            DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) 
     525            ! 
    432526         END DO 
    433527         ! 
    … …  
    449543            IF( TRIM(cobstypessurf(jtype)) == 'sst' )   llnightav(jtype) = ln_sstnight 
    450544            ! 
     545            ALLOCATE( clvars( nvarssurf(jtype) ) ) 
     546            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     547               clvars(1) = 'SLA' 
     548            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 
     549               clvars(1) = 'SST' 
     550            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 
     551               clvars(1) = 'ICECONC' 
     552            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 
     553               clvars(1) = 'SSS' 
     554            ENDIF 
     555            ! 
    451556            ! Read in surface obs types 
    452557            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 
    453558               &               clsurffiles(jtype,1:ifilessurf(jtype)), & 
    454559               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 
    455                &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 
     560               &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & 
     561               &               clvars ) 
    456562               ! 
    457563            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 
    … …  
    473579                  &                  jnumsstbias      , cn_sstbiasfiles(1:jnumsstbias) )  
    474580            ENDIF 
     581            ! 
     582            DEALLOCATE( clvars ) 
    475583         END DO 
    476584         ! 
    … …  
    516624      INTEGER :: jvar              ! Variable number 
    517625      INTEGER :: ji, jj            ! Loop counters 
    518       REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 
    519          & zprofvar1, &            ! Model values for 1st variable in a prof ob 
    520          & zprofvar2               ! Model values for 2nd variable in a prof ob 
    521       REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 
    522          & zprofmask1, &           ! Mask associated with zprofvar1 
    523          & zprofmask2              ! Mask associated with zprofvar2 
     626      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
     627         & zprofvar                ! Model values for variables in a prof ob 
     628      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
     629         & zprofmask               ! Mask associated with zprofvar 
    524630      REAL(wp), DIMENSION(jpi,jpj) :: & 
    525631         & zsurfvar, &             ! Model values equivalent to surface ob. 
    526632         & zsurfmask               ! Mask associated with surface variable 
    527       REAL(wp), DIMENSION(jpi,jpj) :: & 
    528          & zglam1,    &            ! Model longitudes for prof variable 1 
    529          & zglam2,    &            ! Model longitudes for prof variable 2 
    530          & zgphi1,    &            ! Model latitudes for prof variable 1 
    531          & zgphi2                  ! Model latitudes for prof variable 2 
     633      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
     634         & zglam,    &             ! Model longitudes for prof variables 
     635         & zgphi                   ! Model latitudes for prof variables 
    532636 
    533637      !----------------------------------------------------------------------- 
    … …  
    549653         DO jtype = 1, nproftypes 
    550654 
     655            ! Allocate local work arrays 
     656            ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 
     657            ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 
     658            ALLOCATE( zglam    (jpi, jpj,      profdataqc(jtype)%nvar) ) 
     659            ALLOCATE( zgphi    (jpi, jpj,      profdataqc(jtype)%nvar) )   
     660                               
     661            ! Defaults which might change 
     662            DO jvar = 1, profdataqc(jtype)%nvar 
     663               zprofmask(:,:,:,jvar) = tmask(:,:,:) 
     664               zglam(:,:,jvar)       = glamt(:,:) 
     665               zgphi(:,:,jvar)       = gphit(:,:) 
     666            END DO 
     667 
    551668            SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 
    552669            CASE('prof') 
    553                zprofvar1(:,:,:) = ts(:,:,:,jp_tem,Kmm) 
    554                zprofvar2(:,:,:) = ts(:,:,:,jp_sal,Kmm) 
    555                zprofmask1(:,:,:) = tmask(:,:,:) 
    556                zprofmask2(:,:,:) = tmask(:,:,:) 
    557                zglam1(:,:) = glamt(:,:) 
    558                zglam2(:,:) = glamt(:,:) 
    559                zgphi1(:,:) = gphit(:,:) 
    560                zgphi2(:,:) = gphit(:,:) 
     670               zprofvar(:,:,:,1) = ts(:,:,:,jp_tem,Kmm) 
     671               zprofvar(:,:,:,2) = ts(:,:,:,jp_sal,Kmm) 
    561672            CASE('vel') 
    562                zprofvar1(:,:,:) = uu(:,:,:,Kmm) 
    563                zprofvar2(:,:,:) = vv(:,:,:,Kmm) 
    564                zprofmask1(:,:,:) = umask(:,:,:) 
    565                zprofmask2(:,:,:) = vmask(:,:,:) 
    566                zglam1(:,:) = glamu(:,:) 
    567                zglam2(:,:) = glamv(:,:) 
    568                zgphi1(:,:) = gphiu(:,:) 
    569                zgphi2(:,:) = gphiv(:,:) 
     673               zprofvar(:,:,:,1) = uu(:,:,:,Kmm) 
     674               zprofvar(:,:,:,2) = vv(:,:,:,Kmm) 
     675               zprofmask(:,:,:,1) = umask(:,:,:) 
     676               zprofmask(:,:,:,2) = vmask(:,:,:) 
     677               zglam(:,:,1) = glamu(:,:) 
     678               zglam(:,:,2) = glamv(:,:) 
     679               zgphi(:,:,1) = gphiu(:,:) 
     680               zgphi(:,:,2) = gphiv(:,:) 
    570681            CASE DEFAULT 
    571682               CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 
    572683            END SELECT 
    573684 
    574             CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  & 
    575                &               nit000, idaystp,                         & 
    576                &               zprofvar1, zprofvar2,                    & 
    577                &               gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm),      &  
    578                &               zprofmask1, zprofmask2,                  & 
    579                &               zglam1, zglam2, zgphi1, zgphi2,          & 
    580                &               nn_1dint, nn_2dint,                      & 
    581                &               kdailyavtypes = nn_profdavtypes ) 
     685            DO jvar = 1, profdataqc(jtype)%nvar 
     686               CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  & 
     687                  &               nit000, idaystp, jvar,                   & 
     688                  &               zprofvar(:,:,:,jvar),                    & 
     689                  &               gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm),      &  
     690                  &               zprofmask(:,:,:,jvar),                   & 
     691                  &               zglam(:,:,jvar), zgphi(:,:,jvar),        & 
     692                  &               nn_1dint, nn_2dint_default,              & 
     693                  &               kdailyavtypes = nn_profdavtypes ) 
     694            END DO 
     695             
     696            DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) 
    582697 
    583698         END DO 
    … …  
    680795                  & ) 
    681796 
    682                CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv ) 
     797               CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 
    683798 
    684799               DO jo = 1, profdataqc(jtype)%nprof 
    … …  
    8961011   END SUBROUTINE fin_date 
    8971012    
    898     SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, & 
    899        &                         cfilestype, ifiles, cobstypes, cfiles ) 
    900  
    901     INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types 
    902     INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 
    903     INTEGER, INTENT(IN) :: jtype       ! Index of the current type of obs 
    904     INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 
    905        &                   ifiles      ! Out appended number of files for this type 
    906  
    907     CHARACTER(len=6), INTENT(IN) :: ctypein  
    908     CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & 
    909        &                   cfilestype  ! In list of files for this obs type 
    910     CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: & 
    911        &                   cobstypes   ! Out appended list of obs types 
    912     CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & 
    913        &                   cfiles      ! Out appended list of files for all types 
    914  
    915     !Local variables 
    916     INTEGER :: jfile 
    917  
    918     cfiles(jtype,:) = cfilestype(:) 
    919     cobstypes(jtype) = ctypein 
    920     ifiles(jtype) = 0 
    921     DO jfile = 1, jpmaxnfiles 
    922        IF ( trim(cfiles(jtype,jfile)) /= '' ) & 
    923                  ifiles(jtype) = ifiles(jtype) + 1 
    924     END DO 
    925  
    926     IF ( ifiles(jtype) == 0 ) THEN 
    927          CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)//   & 
    928             &           ' set to true but no files available to read' ) 
    929     ENDIF 
    930  
    931     IF(lwp) THEN     
    932        WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:' 
    933        DO jfile = 1, ifiles(jtype) 
    934           WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile)) 
    935        END DO 
    936     ENDIF 
    937  
    938     END SUBROUTINE obs_settypefiles 
    939  
    940     SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             & 
    941                &                  n2dint_default, n2dint_type,        & 
    942                &                  zavglamscl_type, zavgphiscl_type,   & 
    943                &                  lfp_indegs_type, lavnight_type,     & 
    944                &                  n2dint, zavglamscl, zavgphiscl,     & 
    945                &                  lfpindegs, lavnight ) 
    946  
    947     INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types 
    948     INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs 
    949     INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type 
    950     INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type 
    951     REAL(wp), INTENT(IN) :: & 
    952        &                    zavglamscl_type, & !E/W diameter of obs footprint for this type 
    953        &                    zavgphiscl_type    !N/S diameter of obs footprint for this type 
    954     LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres 
    955     LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average 
    956     CHARACTER(len=6), INTENT(IN) :: ctypein  
    957  
    958     INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 
    959        &                    n2dint  
    960     REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 
    961        &                    zavglamscl, zavgphiscl 
    962     LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 
    963        &                    lfpindegs, lavnight 
    964  
    965     lavnight(jtype) = lavnight_type 
    966  
    967     IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN 
    968        n2dint(jtype) = n2dint_type 
    969     ELSE 
    970        n2dint(jtype) = n2dint_default 
    971     ENDIF 
    972  
    973     ! For averaging observation footprints set options for size of footprint  
    974     IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 
    975        IF ( zavglamscl_type > 0._wp ) THEN 
    976           zavglamscl(jtype) = zavglamscl_type 
    977        ELSE 
    978           CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
    979                          'scale (zavglamscl) for observation type '//TRIM(ctypein) )       
    980        ENDIF 
    981  
    982        IF ( zavgphiscl_type > 0._wp ) THEN 
    983           zavgphiscl(jtype) = zavgphiscl_type 
    984        ELSE 
    985           CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
    986                          'scale (zavgphiscl) for observation type '//TRIM(ctypein) )       
    987        ENDIF 
    988  
    989        lfpindegs(jtype) = lfp_indegs_type  
    990  
    991     ENDIF 
    992  
    993     ! Write out info  
    994     IF(lwp) THEN 
    995        IF ( n2dint(jtype) <= 4 ) THEN 
    996           WRITE(numout,*) '             '//TRIM(ctypein)// & 
    997              &            ' model counterparts will be interpolated horizontally' 
    998        ELSE IF ( n2dint(jtype) <= 6 ) THEN 
    999           WRITE(numout,*) '             '//TRIM(ctypein)// & 
    1000              &            ' model counterparts will be averaged horizontally' 
    1001           WRITE(numout,*) '             '//'    with E/W scale: ',zavglamscl(jtype) 
    1002           WRITE(numout,*) '             '//'    with N/S scale: ',zavgphiscl(jtype) 
    1003           IF ( lfpindegs(jtype) ) THEN 
    1004               WRITE(numout,*) '             '//'    (in degrees)' 
    1005           ELSE 
    1006               WRITE(numout,*) '             '//'    (in metres)' 
    1007           ENDIF 
    1008        ENDIF 
    1009     ENDIF 
    1010  
    1011     END SUBROUTINE obs_setinterpopts 
     1013   SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 
     1014 
     1015      INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types 
     1016      INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 
     1017      INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 
     1018         &                   ifiles      ! Out number of files for each type 
     1019      CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 
     1020         &                   cobstypes   ! List of obs types 
     1021      CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 
     1022         &                   cfiles      ! List of files for all types 
     1023 
     1024      !Local variables 
     1025      INTEGER :: jfile 
     1026      INTEGER :: jtype 
     1027 
     1028      DO jtype = 1, ntypes 
     1029 
     1030         ifiles(jtype) = 0 
     1031         DO jfile = 1, jpmaxnfiles 
     1032            IF ( trim(cfiles(jtype,jfile)) /= '' ) & 
     1033                      ifiles(jtype) = ifiles(jtype) + 1 
     1034         END DO 
     1035 
     1036         IF ( ifiles(jtype) == 0 ) THEN 
     1037              CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))//  & 
     1038                 &           ' set to true but no files available to read' ) 
     1039         ENDIF 
     1040 
     1041         IF(lwp) THEN     
     1042            WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:' 
     1043            DO jfile = 1, ifiles(jtype) 
     1044               WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile)) 
     1045            END DO 
     1046         ENDIF 
     1047 
     1048      END DO 
     1049 
     1050   END SUBROUTINE obs_settypefiles 
     1051 
     1052   SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             & 
     1053              &                  n2dint_default, n2dint_type,        & 
     1054              &                  ravglamscl_type, ravgphiscl_type,   & 
     1055              &                  lfp_indegs_type, lavnight_type,     & 
     1056              &                  n2dint, ravglamscl, ravgphiscl,     & 
     1057              &                  lfpindegs, lavnight ) 
     1058 
     1059      INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types 
     1060      INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs 
     1061      INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type 
     1062      INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type 
     1063      REAL(wp), INTENT(IN) :: & 
     1064         &                    ravglamscl_type, & !E/W diameter of obs footprint for this type 
     1065         &                    ravgphiscl_type    !N/S diameter of obs footprint for this type 
     1066      LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres 
     1067      LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average 
     1068      CHARACTER(len=8), INTENT(IN) :: ctypein  
     1069 
     1070      INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 
     1071         &                    n2dint  
     1072      REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 
     1073         &                    ravglamscl, ravgphiscl 
     1074      LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 
     1075         &                    lfpindegs, lavnight 
     1076 
     1077      lavnight(jtype) = lavnight_type 
     1078 
     1079      IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 
     1080         n2dint(jtype) = n2dint_type 
     1081      ELSE IF ( n2dint_type == -1 ) THEN 
     1082         n2dint(jtype) = n2dint_default 
     1083      ELSE 
     1084         CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 
     1085           &                    ' is not available') 
     1086      ENDIF 
     1087 
     1088      ! For averaging observation footprints set options for size of footprint  
     1089      IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 
     1090         IF ( ravglamscl_type > 0._wp ) THEN 
     1091            ravglamscl(jtype) = ravglamscl_type 
     1092         ELSE 
     1093            CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
     1094                           'scale (ravglamscl) for observation type '//TRIM(ctypein) )       
     1095         ENDIF 
     1096 
     1097         IF ( ravgphiscl_type > 0._wp ) THEN 
     1098            ravgphiscl(jtype) = ravgphiscl_type 
     1099         ELSE 
     1100            CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
     1101                           'scale (ravgphiscl) for observation type '//TRIM(ctypein) )       
     1102         ENDIF 
     1103 
     1104         lfpindegs(jtype) = lfp_indegs_type  
     1105 
     1106      ENDIF 
     1107 
     1108      ! Write out info  
     1109      IF(lwp) THEN 
     1110         IF ( n2dint(jtype) <= 4 ) THEN 
     1111            WRITE(numout,*) '             '//TRIM(ctypein)// & 
     1112               &            ' model counterparts will be interpolated horizontally' 
     1113         ELSE IF ( n2dint(jtype) <= 6 ) THEN 
     1114            WRITE(numout,*) '             '//TRIM(ctypein)// & 
     1115               &            ' model counterparts will be averaged horizontally' 
     1116            WRITE(numout,*) '             '//'    with E/W scale: ',ravglamscl(jtype) 
     1117            WRITE(numout,*) '             '//'    with N/S scale: ',ravgphiscl(jtype) 
     1118            IF ( lfpindegs(jtype) ) THEN 
     1119                WRITE(numout,*) '             '//'    (in degrees)' 
     1120            ELSE 
     1121                WRITE(numout,*) '             '//'    (in metres)' 
     1122            ENDIF 
     1123         ENDIF 
     1124      ENDIF 
     1125 
     1126   END SUBROUTINE obs_setinterpopts 
    10121127 
    10131128END MODULE diaobs 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_oper.F90

    r13295 r14062  
    4040CONTAINS 
    4141 
    42    SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk,          & 
    43       &                     kit000, kdaystp,                      & 
    44       &                     pvar1, pvar2, pgdept, pgdepw,         & 
    45       &                     pmask1, pmask2,                       &   
    46       &                     plam1, plam2, pphi1, pphi2,           & 
     42   SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 
     43      &                     kit000, kdaystp, kvar,       & 
     44      &                     pvar, pgdept, pgdepw,        & 
     45      &                     pmask,                       &   
     46      &                     plam, pphi,                  & 
    4747      &                     k1dint, k2dint, kdailyavtypes ) 
    4848      !!----------------------------------------------------------------------- 
    … …  
    105105      INTEGER       , INTENT(in   ) ::   k2dint          ! Horizontal interpolation type (see header) 
    106106      INTEGER       , INTENT(in   ) ::   kdaystp         ! Number of time steps per day 
    107       REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pvar1 , pvar2    ! Model field     1 and 2 
    108       REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pmask1, pmask2   ! Land-sea mask   1 and 2 
    109       REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   plam1 , plam2    ! Model longitude 1 and 2 
    110       REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   pphi1 , pphi2    ! Model latitudes 1 and 2 
     107      INTEGER       , INTENT(in   ) ::   kvar            ! Number of variables in prodatqc 
     108      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pvar             ! Model field 
     109      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pmask            ! Land-sea mask 
     110      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   plam             ! Model longitude 
     111      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   pphi             ! Model latitudes 
    111112      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pgdept, pgdepw   ! depth of T and W levels  
    112113      INTEGER, DIMENSION(imaxavtypes), OPTIONAL ::   kdailyavtypes             ! Types for daily averages 
    … …  
    128129         & idailyavtypes 
    129130      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    130          & igrdi1, & 
    131          & igrdi2, & 
    132          & igrdj1, & 
    133          & igrdj2 
     131         & igrdi, & 
     132         & igrdj 
    134133      INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 
    135134 
    … …  
    138137      REAL(KIND=wp) :: zdaystp 
    139138      REAL(KIND=wp), DIMENSION(kpk) :: & 
    140          & zobsmask1, & 
    141          & zobsmask2, & 
    142          & zobsk,    & 
     139         & zobsk,  & 
    143140         & zobs2k 
    144141      REAL(KIND=wp), DIMENSION(2,2,1) :: & 
    145142         & zweig1, & 
    146          & zweig2, & 
    147143         & zweig 
    148144      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
    149          & zmask1, & 
    150          & zmask2, & 
    151          & zint1,  & 
    152          & zint2,  & 
    153          & zinm1,  & 
    154          & zinm2,  & 
     145         & zmask,  & 
     146         & zint,   & 
     147         & zinm,   & 
    155148         & zgdept, &  
    156149         & zgdepw 
    157150      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    158          & zglam1, & 
    159          & zglam2, & 
    160          & zgphi1, & 
    161          & zgphi2 
    162       REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2    
     151         & zglam,  & 
     152         & zgphi 
     153      REAL(KIND=wp), DIMENSION(1) :: zmsk 
    163154      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 
    164155 
    … …  
    190181         IF ( idayend == 1 .OR. kt == 0 ) THEN 
    191182            DO_3D( 1, 1, 1, 1, 1, jpk ) 
    192                prodatqc%vdmean(ji,jj,jk,1) = 0.0 
    193                prodatqc%vdmean(ji,jj,jk,2) = 0.0 
     183               prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 
    194184            END_3D 
    195185         ENDIF 
    … …  
    197187         DO_3D( 1, 1, 1, 1, 1, jpk ) 
    198188            ! Increment field 1 for computing daily mean 
    199             prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
    200                &                        + pvar1(ji,jj,jk) 
    201             ! Increment field 2 for computing daily mean 
    202             prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
    203                &                        + pvar2(ji,jj,jk) 
     189            prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 
     190               &                           + pvar(ji,jj,jk) 
    204191         END_3D 
    205192 
    … …  
    210197            CALL FLUSH(numout) 
    211198            DO_3D( 1, 1, 1, 1, 1, jpk ) 
    212                prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
    213                   &                        * zdaystp 
    214                prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
    215                   &                        * zdaystp 
     199               prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 
     200                  &                           * zdaystp 
    216201            END_3D 
    217202         ENDIF 
    … …  
    221206      ! Get the data for interpolation 
    222207      ALLOCATE( & 
    223          & igrdi1(2,2,ipro),      & 
    224          & igrdi2(2,2,ipro),      & 
    225          & igrdj1(2,2,ipro),      & 
    226          & igrdj2(2,2,ipro),      & 
    227          & zglam1(2,2,ipro),      & 
    228          & zglam2(2,2,ipro),      & 
    229          & zgphi1(2,2,ipro),      & 
    230          & zgphi2(2,2,ipro),      & 
    231          & zmask1(2,2,kpk,ipro),  & 
    232          & zmask2(2,2,kpk,ipro),  & 
    233          & zint1(2,2,kpk,ipro),   & 
    234          & zint2(2,2,kpk,ipro),   & 
    235          & zgdept(2,2,kpk,ipro),  &  
    236          & zgdepw(2,2,kpk,ipro)   &  
     208         & igrdi(2,2,ipro),      & 
     209         & igrdj(2,2,ipro),      & 
     210         & zglam(2,2,ipro),      & 
     211         & zgphi(2,2,ipro),      & 
     212         & zmask(2,2,kpk,ipro),  & 
     213         & zint(2,2,kpk,ipro),   & 
     214         & zgdept(2,2,kpk,ipro), &  
     215         & zgdepw(2,2,kpk,ipro)  &  
    237216         & ) 
    238217 
    239218      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    240219         iobs = jobs - prodatqc%nprofup 
    241          igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 
    242          igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 
    243          igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 
    244          igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 
    245          igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 
    246          igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 
    247          igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 
    248          igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 
    249          igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 
    250          igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 
    251          igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 
    252          igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 
    253          igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 
    254          igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 
    255          igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 
    256          igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 
     220         igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 
     221         igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 
     222         igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 
     223         igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 
     224         igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 
     225         igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 
     226         igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 
     227         igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 
    257228      END DO 
    258229 
    … …  
    261232      zgdepw(:,:,:,:) = 0.0 
    262233 
    263       CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 
    264       CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 
    265       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 
    266       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1,   zint1 ) 
    267        
    268       CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 
    269       CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 
    270       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 
    271       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2,   zint2 ) 
    272  
    273       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept )  
    274       CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw )  
     234      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     235      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
     236      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 
     237      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar,   zint ) 
     238 
     239      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept )  
     240      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw )  
    275241 
    276242      ! At the end of the day also get interpolated means 
    277243      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
    278244 
    279          ALLOCATE( & 
    280             & zinm1(2,2,kpk,ipro),  & 
    281             & zinm2(2,2,kpk,ipro)   & 
    282             & ) 
    283  
    284          CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 
    285             &                  prodatqc%vdmean(:,:,:,1), zinm1 ) 
    286          CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 
    287             &                  prodatqc%vdmean(:,:,:,2), zinm2 ) 
     245         ALLOCATE( zinm(2,2,kpk,ipro) ) 
     246 
     247         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 
     248            &                  prodatqc%vdmean(:,:,:,kvar), zinm ) 
    288249 
    289250      ENDIF 
    … …  
    320281         ! Horizontal weights  
    321282         ! Masked values are calculated later.   
    322          IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
     283         IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 
    323284 
    324285            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     & 
    325                &                   zglam1(:,:,iobs), zgphi1(:,:,iobs), & 
    326                &                   zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 
    327  
    328          ENDIF 
    329  
    330          IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
    331  
    332             CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     & 
    333                &                   zglam2(:,:,iobs), zgphi2(:,:,iobs), & 
    334                &                   zmask2(:,:,1,iobs), zweig2, zmsk_2) 
    335   
    336          ENDIF 
    337  
    338          IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
     286               &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
     287               &                   zmask(:,:,1,iobs), zweig1, zmsk ) 
     288 
     289         ENDIF 
     290 
     291         IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 
    339292 
    340293            zobsk(:) = obfillflt 
    … …  
    346299 
    347300                  ! vertically interpolate all 4 corners  
    348                   ista = prodatqc%npvsta(jobs,1)  
    349                   iend = prodatqc%npvend(jobs,1)  
     301                  ista = prodatqc%npvsta(jobs,kvar)  
     302                  iend = prodatqc%npvend(jobs,kvar)  
    350303                  inum_obs = iend - ista + 1  
    351304                  ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs))  
    … …  
    356309                        IF ( k1dint == 1 ) THEN  
    357310                           CALL obs_int_z1d_spl( kpk, &  
    358                               &     zinm1(iin,ijn,:,iobs), &  
     311                              &     zinm(iin,ijn,:,iobs), &  
    359312                              &     zobs2k, zgdept(iin,ijn,:,iobs), &  
    360                               &     zmask1(iin,ijn,:,iobs))  
     313                              &     zmask(iin,ijn,:,iobs))  
    361314                        ENDIF  
    362315        
    363316                        CALL obs_level_search(kpk, &  
    364317                           &    zgdept(iin,ijn,:,iobs), &  
    365                            &    inum_obs, prodatqc%var(1)%vdep(ista:iend), &  
     318                           &    inum_obs, prodatqc%var(kvar)%vdep(ista:iend), &  
    366319                           &    iv_indic)  
    367320 
    368321                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
    369                            &    prodatqc%var(1)%vdep(ista:iend), &  
    370                            &    zinm1(iin,ijn,:,iobs), &  
     322                           &    prodatqc%var(kvar)%vdep(ista:iend), &  
     323                           &    zinm(iin,ijn,:,iobs), &  
    371324                           &    zobs2k, interp_corner(iin,ijn,:), &  
    372325                           &    zgdept(iin,ijn,:,iobs), &  
    373                            &    zmask1(iin,ijn,:,iobs))  
     326                           &    zmask(iin,ijn,:,iobs))  
    374327        
    375328                     ENDDO  
    … …  
    383336      
    384337               ! vertically interpolate all 4 corners  
    385                ista = prodatqc%npvsta(jobs,1)  
    386                iend = prodatqc%npvend(jobs,1)  
     338               ista = prodatqc%npvsta(jobs,kvar)  
     339               iend = prodatqc%npvend(jobs,kvar)  
    387340               inum_obs = iend - ista + 1  
    388341               ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs))  
    … …  
    392345                     IF ( k1dint == 1 ) THEN  
    393346                        CALL obs_int_z1d_spl( kpk, &  
    394                            &    zint1(iin,ijn,:,iobs),&  
     347                           &    zint(iin,ijn,:,iobs),&  
    395348                           &    zobs2k, zgdept(iin,ijn,:,iobs), &  
    396                            &    zmask1(iin,ijn,:,iobs))  
     349                           &    zmask(iin,ijn,:,iobs))  
    397350   
    398351                     ENDIF  
    … …  
    400353                     CALL obs_level_search(kpk, &  
    401354                         &        zgdept(iin,ijn,:,iobs),&  
    402                          &        inum_obs, prodatqc%var(1)%vdep(ista:iend), &  
     355                         &        inum_obs, prodatqc%var(kvar)%vdep(ista:iend), &  
    403356                         &        iv_indic)  
    404357 
    405358                     CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     &  
    406                          &          prodatqc%var(1)%vdep(ista:iend),     &  
    407                          &          zint1(iin,ijn,:,iobs),            &  
     359                         &          prodatqc%var(kvar)%vdep(ista:iend),     &  
     360                         &          zint(iin,ijn,:,iobs),            &  
    408361                         &          zobs2k,interp_corner(iin,ijn,:), &  
    409362                         &          zgdept(iin,ijn,:,iobs),         &  
    410                          &          zmask1(iin,ijn,:,iobs) )       
     363                         &          zmask(iin,ijn,:,iobs) )       
    411364          
    412365                  ENDDO  
    … …  
    432385                  DO ijn=1,2  
    433386      
    434                      depth_loop1: DO ik=kpk,2,-1  
    435                         IF(zmask1(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
     387                     depth_loop: DO ik=kpk,2,-1  
     388                        IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
    436389                             
    437390                           zweig(iin,ijn,1) = &   
    438391                              & zweig1(iin,ijn,1) * &  
    439392                              & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) &  
    440                               &  - prodatqc%var(1)%vdep(iend)),0._wp)  
     393                              &  - prodatqc%var(kvar)%vdep(iend)),0._wp)  
    441394                             
    442                            EXIT depth_loop1  
     395                           EXIT depth_loop  
    443396 
    444397                        ENDIF  
    445398 
    446                      ENDDO depth_loop1  
     399                     ENDDO depth_loop 
    447400      
    448401                  ENDDO  
    … …  
    450403    
    451404               CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), &  
    452                   &              prodatqc%var(1)%vmod(iend:iend) )  
     405                  &              prodatqc%var(kvar)%vmod(iend:iend) )  
    453406 
    454407                  ! Set QC flag for any observations found below the bottom 
    455408                  ! needed as the check here is more strict than that in obs_prep 
    456                IF (sum(zweig) == 0.0_wp) prodatqc%var(1)%nvqc(iend:iend)=4 
     409               IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 
    457410  
    458411            ENDDO  
    … …  
    460413            DEALLOCATE(interp_corner,iv_indic)  
    461414           
    462          ENDIF  
    463  
    464          ! For the second variable 
    465          IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
    466  
    467             zobsk(:) = obfillflt 
    468  
    469             IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
    470  
    471                IF ( idayend == 0 )  THEN 
    472                   ! Daily averaged data 
    473  
    474                   ! vertically interpolate all 4 corners  
    475                   ista = prodatqc%npvsta(jobs,2)  
    476                   iend = prodatqc%npvend(jobs,2)  
    477                   inum_obs = iend - ista + 1  
    478                   ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs))  
    479  
    480                   DO iin=1,2  
    481                      DO ijn=1,2  
    482  
    483                         IF ( k1dint == 1 ) THEN  
    484                            CALL obs_int_z1d_spl( kpk, &  
    485                               &     zinm2(iin,ijn,:,iobs), &  
    486                               &     zobs2k, zgdept(iin,ijn,:,iobs), &  
    487                               &     zmask2(iin,ijn,:,iobs))  
    488                         ENDIF  
    489         
    490                         CALL obs_level_search(kpk, &  
    491                            &    zgdept(iin,ijn,:,iobs), &  
    492                            &    inum_obs, prodatqc%var(2)%vdep(ista:iend), &  
    493                            &    iv_indic)  
    494  
    495                         CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
    496                            &    prodatqc%var(2)%vdep(ista:iend), &  
    497                            &    zinm2(iin,ijn,:,iobs), &  
    498                            &    zobs2k, interp_corner(iin,ijn,:), &  
    499                            &    zgdept(iin,ijn,:,iobs), &  
    500                            &    zmask2(iin,ijn,:,iobs))  
    501         
    502                      ENDDO  
    503                   ENDDO  
    504  
    505                ENDIF !idayend 
    506  
    507             ELSE    
    508  
    509                ! Point data  
    510       
    511                ! vertically interpolate all 4 corners  
    512                ista = prodatqc%npvsta(jobs,2)  
    513                iend = prodatqc%npvend(jobs,2)  
    514                inum_obs = iend - ista + 1  
    515                ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs))  
    516                DO iin=1,2   
    517                   DO ijn=1,2  
    518                      
    519                      IF ( k1dint == 1 ) THEN  
    520                         CALL obs_int_z1d_spl( kpk, &  
    521                            &    zint2(iin,ijn,:,iobs),&  
    522                            &    zobs2k, zgdept(iin,ijn,:,iobs), &  
    523                            &    zmask2(iin,ijn,:,iobs))  
    524    
    525                      ENDIF  
    526         
    527                      CALL obs_level_search(kpk, &  
    528                          &        zgdept(iin,ijn,:,iobs),&  
    529                          &        inum_obs, prodatqc%var(2)%vdep(ista:iend), &  
    530                          &        iv_indic)  
    531  
    532                      CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     &  
    533                          &          prodatqc%var(2)%vdep(ista:iend),     &  
    534                          &          zint2(iin,ijn,:,iobs),            &  
    535                          &          zobs2k,interp_corner(iin,ijn,:), &  
    536                          &          zgdept(iin,ijn,:,iobs),         &  
    537                          &          zmask2(iin,ijn,:,iobs) )       
    538           
    539                   ENDDO  
    540                ENDDO  
    541               
    542             ENDIF  
    543  
    544             !-------------------------------------------------------------  
    545             ! Compute the horizontal interpolation for every profile level  
    546             !-------------------------------------------------------------  
    547               
    548             DO ikn=1,inum_obs  
    549                iend=ista+ikn-1 
    550                    
    551                zweig(:,:,1) = 0._wp  
    552     
    553                ! This code forces the horizontal weights to be   
    554                ! zero IF the observation is below the bottom of the   
    555                ! corners of the interpolation nodes, Or if it is in   
    556                ! the mask. This is important for observations near   
    557                ! steep bathymetry  
    558                DO iin=1,2  
    559                   DO ijn=1,2  
    560       
    561                      depth_loop2: DO ik=kpk,2,-1  
    562                         IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
    563                              
    564                            zweig(iin,ijn,1) = &   
    565                               & zweig2(iin,ijn,1) * &  
    566                               & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) &  
    567                               &  - prodatqc%var(2)%vdep(iend)),0._wp)  
    568                              
    569                            EXIT depth_loop2  
    570  
    571                         ENDIF  
    572  
    573                      ENDDO depth_loop2  
    574       
    575                   ENDDO  
    576                ENDDO  
    577     
    578                CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), &  
    579                   &              prodatqc%var(2)%vmod(iend:iend) )  
    580  
    581                   ! Set QC flag for any observations found below the bottom 
    582                   ! needed as the check here is more strict than that in obs_prep 
    583                IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 
    584   
    585             ENDDO  
    586   
    587             DEALLOCATE(interp_corner,iv_indic)  
    588            
    589          ENDIF  
     415         ENDIF 
    590416 
    591417      ENDDO 
    592418 
    593419      ! Deallocate the data for interpolation 
    594       DEALLOCATE( & 
    595          & igrdi1, & 
    596          & igrdi2, & 
    597          & igrdj1, & 
    598          & igrdj2, & 
    599          & zglam1, & 
    600          & zglam2, & 
    601          & zgphi1, & 
    602          & zgphi2, & 
    603          & zmask1, & 
    604          & zmask2, & 
    605          & zint1,  & 
    606          & zint2,  & 
     420      DEALLOCATE(  & 
     421         & igrdi,  & 
     422         & igrdj,  & 
     423         & zglam,  & 
     424         & zgphi,  & 
     425         & zmask,  & 
     426         & zint,   & 
    607427         & zgdept, & 
    608428         & zgdepw  & 
    … …  
    611431      ! At the end of the day also get interpolated means 
    612432      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
    613          DEALLOCATE( & 
    614             & zinm1,  & 
    615             & zinm2   & 
    616             & ) 
     433         DEALLOCATE( zinm ) 
    617434      ENDIF 
    618435 
    619       prodatqc%nprofup = prodatqc%nprofup + ipro  
     436      IF ( kvar == prodatqc%nvar ) THEN 
     437         prodatqc%nprofup = prodatqc%nprofup + ipro  
     438      ENDIF 
    620439 
    621440   END SUBROUTINE obs_prof_opt 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_prep.F90

    r12489 r14062  
    241241 
    242242 
    243    SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 
     243   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 
    244244      &                     kpi, kpj, kpk, & 
    245       &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  & 
     245      &                     zmask, pglam, pgphi,  & 
    246246      &                     ld_nea, ld_bound_reject, Kmm, kdailyavtypes,  kqc_cutoff ) 
    247247 
    … …  
    269269      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    270270      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
    271       LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches 
    272       LOGICAL, INTENT(IN) :: ld_var2 
     271      LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 
     272         & ld_var                                 ! Observed variables switches 
    273273      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
    274274      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary 
    … …  
    277277      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    278278         & kdailyavtypes                          ! Types for daily averages 
    279       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    280          & zmask1, & 
    281          & zmask2 
    282       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    283          & pglam1, & 
    284          & pglam2, & 
    285          & pgphi1, & 
    286          & pgphi2 
     279      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 
     280         & zmask 
     281      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 
     282         & pglam, & 
     283         & pgphi 
    287284      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
    288285 
    … …  
    295292      INTEGER :: imin0 
    296293      INTEGER :: icycle       ! Current assimilation cycle 
    297                               ! Counters for observations that are 
    298       INTEGER :: iotdobs      !  - outside time domain 
    299       INTEGER :: iosdv1obs    !  - outside space domain (variable 1) 
    300       INTEGER :: iosdv2obs    !  - outside space domain (variable 2) 
    301       INTEGER :: ilanv1obs    !  - within a model land cell (variable 1) 
    302       INTEGER :: ilanv2obs    !  - within a model land cell (variable 2) 
    303       INTEGER :: inlav1obs    !  - close to land (variable 1) 
    304       INTEGER :: inlav2obs    !  - close to land (variable 2) 
    305       INTEGER :: ibdyv1obs    !  - boundary (variable 1)  
    306       INTEGER :: ibdyv2obs    !  - boundary (variable 2)       
    307       INTEGER :: igrdobs      !  - fail the grid search 
    308       INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    309       INTEGER :: iuvchkv      ! 
    310                               ! Global counters for observations that are 
    311       INTEGER :: iotdobsmpp   !  - outside time domain 
    312       INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1) 
    313       INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2) 
    314       INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1) 
    315       INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2) 
    316       INTEGER :: inlav1obsmpp !  - close to land (variable 1) 
    317       INTEGER :: inlav2obsmpp !  - close to land (variable 2) 
    318       INTEGER :: ibdyv1obsmpp !  - boundary (variable 1)  
    319       INTEGER :: ibdyv2obsmpp !  - boundary (variable 2)       
    320       INTEGER :: igrdobsmpp   !  - fail the grid search 
    321       INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa 
    322       INTEGER :: iuvchkvmpp   ! 
     294                                                       ! Counters for observations that are 
     295      INTEGER                           :: iotdobs     !  - outside time domain 
     296      INTEGER, DIMENSION(profdata%nvar) :: iosdvobs    !  - outside space domain 
     297      INTEGER, DIMENSION(profdata%nvar) :: ilanvobs    !  - within a model land cell 
     298      INTEGER, DIMENSION(profdata%nvar) :: inlavobs    !  - close to land 
     299      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs    !  - boundary    
     300      INTEGER                           :: igrdobs     !  - fail the grid search 
     301      INTEGER                           :: iuvchku     !  - reject UVEL if VVEL rejected 
     302      INTEGER                           :: iuvchkv     !  - reject VVEL if UVEL rejected 
     303                                                       ! Global counters for observations that are 
     304      INTEGER                           :: iotdobsmpp  !  - outside time domain 
     305      INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp !  - outside space domain 
     306      INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp !  - within a model land cell 
     307      INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp !  - close to land 
     308      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp !  - boundary 
     309      INTEGER :: igrdobsmpp                            !  - fail the grid search 
     310      INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected 
     311      INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected 
    323312      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    324313      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    325          & llvvalid           ! var1,var2 selection  
     314         & llvvalid           ! var selection  
    326315      INTEGER :: jvar         ! Variable loop variable 
    327316      INTEGER :: jobs         ! Obs. loop variable 
    328317      INTEGER :: jstp         ! Time loop variable 
    329318      INTEGER :: inrc         ! Time index variable 
     319      CHARACTER(LEN=256) :: cout1  ! Diagnostic output line 
     320      CHARACTER(LEN=256) :: cout2  ! Diagnostic output line 
    330321      !!---------------------------------------------------------------------- 
    331322 
    … …  
    342333      icycle = nn_no     ! Assimilation cycle 
    343334 
    344       ! Diagnotics counters for various failures. 
    345  
    346       iotdobs   = 0 
    347       igrdobs   = 0 
    348       iosdv1obs = 0 
    349       iosdv2obs = 0 
    350       ilanv1obs = 0 
    351       ilanv2obs = 0 
    352       inlav1obs = 0 
    353       inlav2obs = 0 
    354       ibdyv1obs = 0 
    355       ibdyv2obs = 0 
    356       iuvchku   = 0 
    357       iuvchkv   = 0 
     335      ! Diagnostic counters for various failures. 
     336 
     337      iotdobs     = 0 
     338      igrdobs     = 0 
     339      iosdvobs(:) = 0 
     340      ilanvobs(:) = 0 
     341      inlavobs(:) = 0 
     342      ibdyvobs(:) = 0 
     343      iuvchku     = 0 
     344      iuvchkv     = 0 
    358345 
    359346 
    … …  
    388375      ! ----------------------------------------------------------------------- 
    389376 
    390       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), & 
    391          &              profdata%nqc,     igrdobs                         ) 
    392       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), & 
    393          &              profdata%nqc,     igrdobs                         ) 
     377      DO jvar = 1, profdata%nvar 
     378         CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,jvar), profdata%mj(:,jvar), & 
     379            &              profdata%nqc,     igrdobs                         ) 
     380      END DO 
    394381 
    395382      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    406393      ! ----------------------------------------------------------------------- 
    407394 
    408       ! Variable 1 
    409       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    410          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    411          &                 jpi,                   jpj,                  & 
    412          &                 jpk,                                         & 
    413          &                 profdata%mi,           profdata%mj,          & 
    414          &                 profdata%var(1)%mvk,                         & 
    415          &                 profdata%rlam,         profdata%rphi,        & 
    416          &                 profdata%var(1)%vdep,                        & 
    417          &                 pglam1,                pgphi1,               & 
    418          &                 gdept_1d,              zmask1,               & 
    419          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    420          &                 iosdv1obs,             ilanv1obs,            & 
    421          &                 inlav1obs,             ld_nea,               & 
    422          &                 ibdyv1obs,             ld_bound_reject,      & 
    423          &                 iqc_cutoff,            Kmm                 ) 
    424  
    425       CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 
    426       CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 
    427       CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 
    428       CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 
    429  
    430       ! Variable 2 
    431       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    432          &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    433          &                 jpi,                   jpj,                  & 
    434          &                 jpk,                                         & 
    435          &                 profdata%mi,           profdata%mj,          &  
    436          &                 profdata%var(2)%mvk,                         & 
    437          &                 profdata%rlam,         profdata%rphi,        & 
    438          &                 profdata%var(2)%vdep,                        & 
    439          &                 pglam2,                pgphi2,               & 
    440          &                 gdept_1d,              zmask2,               & 
    441          &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    442          &                 iosdv2obs,             ilanv2obs,            & 
    443          &                 inlav2obs,             ld_nea,               & 
    444          &                 ibdyv2obs,             ld_bound_reject,      & 
    445          &                 iqc_cutoff,            Kmm                 ) 
    446  
    447       CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 
    448       CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 
    449       CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 
    450       CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 
     395      DO jvar = 1, profdata%nvar 
     396         CALL obs_coo_spc_3d( profdata%nprof,          profdata%nvprot(jvar),   & 
     397            &                 profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 
     398            &                 jpi,                     jpj,                     & 
     399            &                 jpk,                                              & 
     400            &                 profdata%mi,             profdata%mj,             & 
     401            &                 profdata%var(jvar)%mvk,                           & 
     402            &                 profdata%rlam,           profdata%rphi,           & 
     403            &                 profdata%var(jvar)%vdep,                          & 
     404            &                 pglam(:,:,jvar),         pgphi(:,:,jvar),         & 
     405            &                 gdept_1d,                zmask(:,:,:,jvar),       & 
     406            &                 profdata%nqc,            profdata%var(jvar)%nvqc, & 
     407            &                 iosdvobs(jvar),          ilanvobs(jvar),          & 
     408            &                 inlavobs(jvar),          ld_nea,                  & 
     409            &                 ibdyvobs(jvar),          ld_bound_reject,         & 
     410            &                 iqc_cutoff,              Kmm       ) 
     411 
     412         CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 
     413         CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 
     414         CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 
     415         CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 
     416      END DO 
    451417 
    452418      ! ----------------------------------------------------------------------- 
    … …  
    499465       
    500466         WRITE(numout,*) 
    501          WRITE(numout,*) ' Profiles outside time domain                     = ', & 
     467         WRITE(numout,*) ' Profiles outside time domain                       = ', & 
    502468            &            iotdobsmpp 
    503          WRITE(numout,*) ' Remaining profiles that failed grid search       = ', & 
     469         WRITE(numout,*) ' Remaining profiles that failed grid search         = ', & 
    504470            &            igrdobsmpp 
    505          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', & 
    506             &            iosdv1obsmpp 
    507          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', & 
    508             &            ilanv1obsmpp 
    509          IF (ld_nea) THEN 
    510             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 
    511                &            inlav1obsmpp 
    512          ELSE 
    513             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',& 
    514                &            inlav1obsmpp 
    515          ENDIF 
    516          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    517             WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    518                &            iuvchku 
    519          ENDIF 
    520          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 
    521                &            ibdyv1obsmpp 
    522          WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', & 
    523             &            prodatqc%nvprotmpp(1) 
    524          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', & 
    525             &            iosdv2obsmpp 
    526          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', & 
    527             &            ilanv2obsmpp 
    528          IF (ld_nea) THEN 
    529             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 
    530                &            inlav2obsmpp 
    531          ELSE 
    532             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',& 
    533                &            inlav2obsmpp 
    534          ENDIF 
    535          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    536             WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    537                &            iuvchkv 
    538          ENDIF 
    539          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 
    540                &            ibdyv2obsmpp 
    541          WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', & 
    542             &            prodatqc%nvprotmpp(2) 
     471         DO jvar = 1, profdata%nvar 
     472            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain       = ', & 
     473               &            iosdvobsmpp(jvar) 
     474            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points             = ', & 
     475               &            ilanvobsmpp(jvar) 
     476            IF (ld_nea) THEN 
     477               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 
     478                  &            inlavobsmpp(jvar) 
     479            ELSE 
     480               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept)    = ',& 
     481                  &            inlavobsmpp(jvar) 
     482            ENDIF 
     483            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 
     484               WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     485                  &            iuvchku 
     486            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 
     487               WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
     488                  &            iuvchkv 
     489            ENDIF 
     490            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 
     491                  &            ibdyvobsmpp(jvar) 
     492            WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted                             = ', & 
     493               &            prodatqc%nvprotmpp(jvar) 
     494         END DO 
    543495 
    544496         WRITE(numout,*) 
    545497         WRITE(numout,*) ' Number of observations per time step :' 
    546498         WRITE(numout,*) 
    547          WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 
    548             &                               '     '//prodatqc%cvars(1)//'     ', & 
    549             &                               '     '//prodatqc%cvars(2)//'     ' 
    550          WRITE(numout,998) 
     499         WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 
     500         WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 
     501         DO jvar = 1, prodatqc%nvar 
     502            WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 
     503            WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 
     504         END DO 
     505         WRITE(numout,*) cout1 
     506         WRITE(numout,*) cout2 
    551507      ENDIF 
    552508       
    … …  
    575531         DO jstp = nit000 - 1, nitend 
    576532            inrc = jstp - nit000 + 2 
    577             WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    578                &                    prodatqc%nvstpmpp(inrc,1), & 
    579                &                    prodatqc%nvstpmpp(inrc,2) 
     533            WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 
     534            DO jvar = 1, prodatqc%nvar 
     535               WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 
     536            END DO 
     537            WRITE(numout,*) cout1 
    580538         END DO 
    581539      ENDIF 
    582  
    583 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    584 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    585540 
    586541   END SUBROUTINE obs_pre_prof 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_read_prof.F90

    r13226 r14062  
    4545   SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 
    4646      &                     kvars, kextr, kstp, ddobsini, ddobsend, & 
    47       &                     ldvar1, ldvar2, ldignmis, ldsatt, & 
    48       &                     ldmod, kdailyavtypes ) 
     47      &                     ldvar, ldignmis, ldsatt, & 
     48      &                     ldmod, cdvars, kdailyavtypes ) 
    4949      !!--------------------------------------------------------------------- 
    5050      !! 
    … …  
    7474      INTEGER, INTENT(IN) :: kextr      ! Number of extra fields for each var 
    7575      INTEGER, INTENT(IN) :: kstp       ! Ocean time-step index 
    76       LOGICAL, INTENT(IN) :: ldvar1     ! Observed variables switches 
    77       LOGICAL, INTENT(IN) :: ldvar2 
     76      LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar     ! Observed variables switches 
    7877      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files 
    7978      LOGICAL, INTENT(IN) :: ldsatt     ! Compute salinity at all temperature points 
    … …  
    8180      REAL(dp), INTENT(IN) :: ddobsini  ! Obs. ini time in YYYYMMDD.HHMMSS 
    8281      REAL(dp), INTENT(IN) :: ddobsend  ! Obs. end time in YYYYMMDD.HHMMSS 
     82      CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 
    8383      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    8484         & kdailyavtypes                ! Types of daily average observations 
    … …  
    8787      CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 
    8888      CHARACTER(len=8) :: clrefdate 
    89       CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 
     89      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 
    9090      INTEGER :: jvar 
    9191      INTEGER :: ji 
    … …  
    105105      INTEGER :: iprof 
    106106      INTEGER :: iproftot 
    107       INTEGER :: ivar1t0 
    108       INTEGER :: ivar2t0 
    109       INTEGER :: ivar1t 
    110       INTEGER :: ivar2t 
     107      INTEGER, DIMENSION(kvars) :: ivart0 
     108      INTEGER, DIMENSION(kvars) :: ivart 
    111109      INTEGER :: ip3dt 
    112110      INTEGER :: ios 
    113111      INTEGER :: ioserrcount 
    114       INTEGER :: ivar1tmpp 
    115       INTEGER :: ivar2tmpp 
     112      INTEGER, DIMENSION(kvars) :: ivartmpp 
    116113      INTEGER :: ip3dtmpp 
    117114      INTEGER :: itype 
    118115      INTEGER, DIMENSION(knumfiles) :: & 
    119116         & irefdate 
    120       INTEGER, DIMENSION(ntyp1770+1) :: & 
    121          & itypvar1,    & 
    122          & itypvar1mpp, & 
    123          & itypvar2,    & 
    124          & itypvar2mpp  
     117      INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 
     118         & itypvar,    & 
     119         & itypvarmpp 
     120      INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 
     121         & iobsi,    & 
     122         & iobsj,    & 
     123         & iproc 
    125124      INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    126          & iobsi1,    & 
    127          & iobsj1,    & 
    128          & iproc1,    & 
    129          & iobsi2,    & 
    130          & iobsj2,    & 
    131          & iproc2,    & 
    132125         & iindx,    & 
    133126         & ifileidx, & 
    … …  
    147140      LOGICAL :: llvalprof 
    148141      LOGICAL :: lldavtimset 
     142      LOGICAL :: llcycle 
    149143      TYPE(obfbdata), POINTER, DIMENSION(:) :: & 
    150144         & inpfiles 
    … …  
    152146      ! Local initialization 
    153147      iprof = 0 
    154       ivar1t0 = 0 
    155       ivar2t0 = 0 
     148      ivart0(:) = 0 
    156149      ip3dt = 0 
    157150 
    … …  
    219212               &                ldgrid = .TRUE. ) 
    220213 
    221             IF ( inpfiles(jj)%nvar < 2 ) THEN 
     214            IF ( inpfiles(jj)%nvar /= kvars ) THEN 
    222215               CALL ctl_stop( 'Feedback format error: ', & 
    223                   &           ' less than 2 vars in profile file' ) 
     216                  &           ' unexpected number of vars in profile file' ) 
    224217            ENDIF 
    225218 
    … …  
    229222 
    230223            IF ( jj == 1 ) THEN 
    231                ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 
     224               ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 
    232225               DO ji = 1, inpfiles(jj)%nvar 
    233                  clvars(ji) = inpfiles(jj)%cname(ji) 
     226                 clvarsin(ji) = inpfiles(jj)%cname(ji) 
     227                 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 
     228                    CALL ctl_stop( 'Feedback file variables do not match', & 
     229                        &           ' expected variable names for this type' ) 
     230                 ENDIF 
    234231               END DO 
    235232            ELSE 
    236233               DO ji = 1, inpfiles(jj)%nvar 
    237                   IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN 
     234                  IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 
    238235                     CALL ctl_stop( 'Feedback file variables not consistent', & 
    239236                        &           ' with previous files for this type' ) 
    … …  
    308305            DO ji = 1, inpfiles(jj)%nobs 
    309306               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    310                IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    311                   & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     307               llcycle = .TRUE. 
     308               DO jvar = 1, kvars 
     309                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     310                     llcycle = .FALSE. 
     311                     EXIT 
     312                  ENDIF 
     313               END DO 
     314               IF ( llcycle ) CYCLE 
    312315               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    313316                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    317320            ALLOCATE( zlam(inowin)  ) 
    318321            ALLOCATE( zphi(inowin)  ) 
    319             ALLOCATE( iobsi1(inowin) ) 
    320             ALLOCATE( iobsj1(inowin) ) 
    321             ALLOCATE( iproc1(inowin) ) 
    322             ALLOCATE( iobsi2(inowin) ) 
    323             ALLOCATE( iobsj2(inowin) ) 
    324             ALLOCATE( iproc2(inowin) ) 
     322            ALLOCATE( iobsi(inowin,kvars) ) 
     323            ALLOCATE( iobsj(inowin,kvars) ) 
     324            ALLOCATE( iproc(inowin,kvars) ) 
    325325            inowin = 0 
    326326            DO ji = 1, inpfiles(jj)%nobs 
    327327               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    328                IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    329                   & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     328               llcycle = .TRUE. 
     329               DO jvar = 1, kvars 
     330                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     331                     llcycle = .FALSE. 
     332                     EXIT 
     333                  ENDIF 
     334               END DO 
     335               IF ( llcycle ) CYCLE 
    330336               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    331337                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    336342            END DO 
    337343 
    338             IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 
    339                CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 
    340                   &                  iproc1, 'T' ) 
    341                iobsi2(:) = iobsi1(:) 
    342                iobsj2(:) = iobsj1(:) 
    343                iproc2(:) = iproc1(:) 
    344             ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 
    345                CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 
    346                   &                  iproc1, 'U' ) 
    347                CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & 
    348                   &                  iproc2, 'V' ) 
     344            ! Assume anything other than velocity is on T grid 
     345            IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 
     346               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 
     347                  &                  iproc(:,1), 'U' ) 
     348               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 
     349                  &                  iproc(:,2), 'V' ) 
     350            ELSE 
     351               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 
     352                  &                  iproc(:,1), 'T' ) 
     353               IF ( kvars > 1 ) THEN 
     354                  DO jvar = 2, kvars 
     355                     iobsi(:,jvar) = iobsi(:,1) 
     356                     iobsj(:,jvar) = iobsj(:,1) 
     357                     iproc(:,jvar) = iproc(:,1) 
     358                  END DO 
     359               ENDIF 
    349360            ENDIF 
    350361 
    … …  
    352363            DO ji = 1, inpfiles(jj)%nobs 
    353364               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    354                IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    355                   & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     365               llcycle = .TRUE. 
     366               DO jvar = 1, kvars 
     367                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     368                     llcycle = .FALSE. 
     369                     EXIT 
     370                  ENDIF 
     371               END DO 
     372               IF ( llcycle ) CYCLE 
    356373               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    357374                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    358375                  inowin = inowin + 1 
    359                   inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 
    360                   inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 
    361                   inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 
    362                   inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 
    363                   inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 
    364                   inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 
    365                   IF ( inpfiles(jj)%iproc(ji,1) /= & 
    366                      & inpfiles(jj)%iproc(ji,2) ) THEN 
    367                      CALL ctl_stop( 'Error in obs_read_prof:', & 
    368                         & 'var1 and var2 observation on different processors') 
     376                  DO jvar = 1, kvars 
     377                     inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 
     378                     inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 
     379                     inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 
     380                  END DO 
     381                  IF ( kvars > 1 ) THEN 
     382                     DO jvar = 2, kvars 
     383                        IF ( inpfiles(jj)%iproc(ji,jvar) /= & 
     384                           & inpfiles(jj)%iproc(ji,1) ) THEN 
     385                           CALL ctl_stop( 'Error in obs_read_prof:', & 
     386                              & 'observation on different processors for different vars') 
     387                        ENDIF 
     388                     END DO 
    369389                  ENDIF 
    370390               ENDIF 
    371391            END DO 
    372             DEALLOCATE( zlam, zphi, iobsi1, iobsj1, iproc1, iobsi2, iobsj2, iproc2 ) 
     392            DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 
    373393 
    374394            DO ji = 1, inpfiles(jj)%nobs 
    375395               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    376                IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    377                   & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     396               llcycle = .TRUE. 
     397               DO jvar = 1, kvars 
     398                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     399                     llcycle = .FALSE. 
     400                     EXIT 
     401                  ENDIF 
     402               END DO 
     403               IF ( llcycle ) CYCLE 
    378404               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    379405                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    384410                  ENDIF 
    385411                  llvalprof = .FALSE. 
    386                   IF ( ldvar1 ) THEN 
    387                      loop_t_count : DO ij = 1,inpfiles(jj)%nlev 
    388                         IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    389                            & CYCLE 
    390                         IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    391                            & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
    392                            ivar1t0 = ivar1t0 + 1 
    393                         ENDIF 
    394                      END DO loop_t_count 
    395                   ENDIF 
    396                   IF ( ldvar2 ) THEN 
    397                      loop_s_count : DO ij = 1,inpfiles(jj)%nlev 
    398                         IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    399                            & CYCLE 
    400                         IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 
    401                            & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
    402                            ivar2t0 = ivar2t0 + 1 
    403                         ENDIF 
    404                      END DO loop_s_count 
    405                   ENDIF 
    406                   loop_p_count : DO ij = 1,inpfiles(jj)%nlev 
     412                  DO jvar = 1, kvars 
     413                     IF ( ldvar(jvar) ) THEN 
     414                        DO ij = 1,inpfiles(jj)%nlev 
     415                           IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
     416                              & CYCLE 
     417                           IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     418                              & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     419                              ivart0(jvar) = ivart0(jvar) + 1 
     420                           ENDIF 
     421                        END DO 
     422                     ENDIF 
     423                  END DO 
     424                  DO ij = 1,inpfiles(jj)%nlev 
    407425                     IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    408426                        & CYCLE 
    409                      IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    410                         &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
    411                         &    ldvar1 ) .OR. & 
    412                         & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 
    413                         &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
    414                         &     ldvar2 ) ) THEN 
    415                         ip3dt = ip3dt + 1 
    416                         llvalprof = .TRUE. 
    417                      ENDIF 
    418                   END DO loop_p_count 
     427                     DO jvar = 1, kvars 
     428                        IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     429                           &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     430                           &    ldvar(jvar) ) ) THEN 
     431                           ip3dt = ip3dt + 1 
     432                           llvalprof = .TRUE. 
     433                           EXIT 
     434                        ENDIF 
     435                     END DO 
     436                  END DO 
    419437 
    420438                  IF ( llvalprof ) iprof = iprof + 1 
    … …  
    438456         DO ji = 1, inpfiles(jj)%nobs 
    439457            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    440             IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    441                & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     458            llcycle = .TRUE. 
     459            DO jvar = 1, kvars 
     460               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     461                  llcycle = .FALSE. 
     462                  EXIT 
     463               ENDIF 
     464            END DO 
     465            IF ( llcycle ) CYCLE 
    442466            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    443467               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    453477         DO ji = 1, inpfiles(jj)%nobs 
    454478            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    455             IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    456                & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     479            llcycle = .TRUE. 
     480            DO jvar = 1, kvars 
     481               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     482                  llcycle = .FALSE. 
     483                  EXIT 
     484               ENDIF 
     485            END DO 
     486            IF ( llcycle ) CYCLE 
    457487            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    458488               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    470500      iv3dt(:) = -1 
    471501      IF (ldsatt) THEN 
    472          iv3dt(1) = ip3dt 
    473          iv3dt(2) = ip3dt 
     502         iv3dt(:) = ip3dt 
    474503      ELSE 
    475          iv3dt(1) = ivar1t0 
    476          iv3dt(2) = ivar2t0 
     504         iv3dt(:) = ivart0(:) 
    477505      ENDIF 
    478506      CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & 
    … …  
    483511      profdata%nprof     = 0 
    484512      profdata%nvprot(:) = 0 
    485       profdata%cvars(:)  = clvars(:) 
     513      profdata%cvars(:)  = clvarsin(:) 
    486514      iprof = 0 
    487515 
    488516      ip3dt = 0 
    489       ivar1t = 0 
    490       ivar2t = 0 
    491       itypvar1   (:) = 0 
    492       itypvar1mpp(:) = 0 
    493  
    494       itypvar2   (:) = 0 
    495       itypvar2mpp(:) = 0 
     517      ivart(:) = 0 
     518      itypvar   (:,:) = 0 
     519      itypvarmpp(:,:) = 0 
    496520 
    497521      ioserrcount = 0 
    … …  
    501525         ji = iprofidx(iindx(jk)) 
    502526 
    503             IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    504             IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    505                & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     527         IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     528         llcycle = .TRUE. 
     529         DO jvar = 1, kvars 
     530            IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     531               llcycle = .FALSE. 
     532               EXIT 
     533            ENDIF 
     534         END DO 
     535         IF ( llcycle ) CYCLE 
    506536 
    507537         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    … …  
    519549 
    520550            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
    521             IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 
    522                & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 
     551            llcycle = .TRUE. 
     552            DO jvar = 1, kvars 
     553               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     554                  llcycle = .FALSE. 
     555                  EXIT 
     556               ENDIF 
     557            END DO 
     558            IF ( llcycle ) CYCLE 
    523559 
    524560            loop_prof : DO ij = 1, inpfiles(jj)%nlev 
    … …  
    527563                  & CYCLE 
    528564 
    529                IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    530                   & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
    531  
    532                   llvalprof = .TRUE.  
    533                   EXIT loop_prof 
    534  
    535                ENDIF 
    536  
    537                IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 
    538                   & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
    539  
    540                   llvalprof = .TRUE.  
    541                   EXIT loop_prof 
    542  
    543                ENDIF 
     565               DO jvar = 1, kvars 
     566                  IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     567                     & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     568 
     569                     llvalprof = .TRUE.  
     570                     EXIT loop_prof 
     571 
     572                  ENDIF 
     573               END DO 
    544574 
    545575            END DO loop_prof 
    … …  
    573603 
    574604               ! Coordinate search parameters 
    575                profdata%mi  (iprof,1) = inpfiles(jj)%iobsi(ji,1) 
    576                profdata%mj  (iprof,1) = inpfiles(jj)%iobsj(ji,1) 
    577                profdata%mi  (iprof,2) = inpfiles(jj)%iobsi(ji,2) 
    578                profdata%mj  (iprof,2) = inpfiles(jj)%iobsj(ji,2) 
     605               DO jvar = 1, kvars 
     606                  profdata%mi  (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 
     607                  profdata%mj  (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 
     608               END DO 
    579609 
    580610               ! Profile WMO number 
    … …  
    616646                  IF (ldsatt) THEN 
    617647 
    618                      IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    619                         &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
    620                         &    ldvar1 ) .OR. & 
    621                         & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 
    622                         &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
    623                         &   ldvar2 ) ) THEN 
    624                         ip3dt = ip3dt + 1 
    625                      ELSE 
    626                         CYCLE 
     648                     DO jvar = 1, kvars 
     649                        IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     650                           &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     651                           &    ldvar(jvar) ) ) THEN 
     652                           ip3dt = ip3dt + 1 
     653                           EXIT 
     654                        ELSE IF ( jvar == kvars ) THEN 
     655                           CYCLE loop_p 
     656                        ENDIF 
     657                     END DO 
     658 
     659                  ENDIF 
     660 
     661                  DO jvar = 1, kvars 
     662                   
     663                     IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     664                       &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     665                       &    ldvar(jvar) ) .OR. ldsatt ) THEN 
     666 
     667                        IF (ldsatt) THEN 
     668 
     669                           ivart(jvar) = ip3dt 
     670 
     671                        ELSE 
     672 
     673                           ivart(jvar) = ivart(jvar) + 1 
     674 
     675                        ENDIF 
     676 
     677                        ! Depth of jvar observation 
     678                        profdata%var(jvar)%vdep(ivart(jvar)) = & 
     679                           &                inpfiles(jj)%pdep(ij,ji) 
     680 
     681                        ! Depth of jvar observation QC 
     682                        profdata%var(jvar)%idqc(ivart(jvar)) = & 
     683                           &                inpfiles(jj)%idqc(ij,ji) 
     684 
     685                        ! Depth of jvar observation QC flags 
     686                        profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 
     687                           &                inpfiles(jj)%idqcf(:,ij,ji) 
     688 
     689                        ! Profile index 
     690                        profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 
     691 
     692                        ! Vertical index in original profile 
     693                        profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 
     694 
     695                        ! Profile jvar value 
     696                        IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     697                           & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     698                           profdata%var(jvar)%vobs(ivart(jvar)) = & 
     699                              &                inpfiles(jj)%pob(ij,ji,jvar) 
     700                           IF ( ldmod ) THEN 
     701                              profdata%var(jvar)%vmod(ivart(jvar)) = & 
     702                                 &                inpfiles(jj)%padd(ij,ji,1,jvar) 
     703                           ENDIF 
     704                           ! Count number of profile var1 data as function of type 
     705                           itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 
     706                              & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 
     707                        ELSE 
     708                           profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 
     709                        ENDIF 
     710 
     711                        ! Profile jvar qc 
     712                        profdata%var(jvar)%nvqc(ivart(jvar)) = & 
     713                           & inpfiles(jj)%ivlqc(ij,ji,jvar) 
     714 
     715                        ! Profile jvar qc flags 
     716                        profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 
     717                           & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 
     718 
     719                        ! Profile insitu T value 
     720                        IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 
     721                           profdata%var(jvar)%vext(ivart(jvar),1) = & 
     722                              &                inpfiles(jj)%pext(ij,ji,1) 
     723                        ENDIF 
     724 
    627725                     ENDIF 
    628  
    629                   ENDIF 
    630  
    631                   IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    632                     &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
    633                     &    ldvar1 ) .OR. ldsatt ) THEN 
    634  
    635                      IF (ldsatt) THEN 
    636  
    637                         ivar1t = ip3dt 
    638  
    639                      ELSE 
    640  
    641                         ivar1t = ivar1t + 1 
    642  
    643                      ENDIF 
    644  
    645                      ! Depth of var1 observation 
    646                      profdata%var(1)%vdep(ivar1t) = & 
    647                         &                inpfiles(jj)%pdep(ij,ji) 
    648  
    649                      ! Depth of var1 observation QC 
    650                      profdata%var(1)%idqc(ivar1t) = & 
    651                         &                inpfiles(jj)%idqc(ij,ji) 
    652  
    653                      ! Depth of var1 observation QC flags 
    654                      profdata%var(1)%idqcf(:,ivar1t) = & 
    655                         &                inpfiles(jj)%idqcf(:,ij,ji) 
    656  
    657                      ! Profile index 
    658                      profdata%var(1)%nvpidx(ivar1t) = iprof 
    659  
    660                      ! Vertical index in original profile 
    661                      profdata%var(1)%nvlidx(ivar1t) = ij 
    662  
    663                      ! Profile var1 value 
    664                      IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 
    665                         & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
    666                         profdata%var(1)%vobs(ivar1t) = & 
    667                            &                inpfiles(jj)%pob(ij,ji,1) 
    668                         IF ( ldmod ) THEN 
    669                            profdata%var(1)%vmod(ivar1t) = & 
    670                               &                inpfiles(jj)%padd(ij,ji,1,1) 
    671                         ENDIF 
    672                         ! Count number of profile var1 data as function of type 
    673                         itypvar1( profdata%ntyp(iprof) + 1 ) = & 
    674                            & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 
    675                      ELSE 
    676                         profdata%var(1)%vobs(ivar1t) = fbrmdi 
    677                      ENDIF 
    678  
    679                      ! Profile var1 qc 
    680                      profdata%var(1)%nvqc(ivar1t) = & 
    681                         & inpfiles(jj)%ivlqc(ij,ji,1) 
    682  
    683                      ! Profile var1 qc flags 
    684                      profdata%var(1)%nvqcf(:,ivar1t) = & 
    685                         & inpfiles(jj)%ivlqcf(:,ij,ji,1) 
    686  
    687                      ! Profile insitu T value 
    688                      IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 
    689                         profdata%var(1)%vext(ivar1t,1) = & 
    690                            &                inpfiles(jj)%pext(ij,ji,1) 
    691                      ENDIF 
    692  
    693                   ENDIF 
    694  
    695                   IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 
    696                      &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2)    .AND. & 
    697                      &   ldvar2 ) .OR. ldsatt ) THEN 
    698  
    699                      IF (ldsatt) THEN 
    700  
    701                         ivar2t = ip3dt 
    702  
    703                      ELSE 
    704  
    705                         ivar2t = ivar2t + 1 
    706  
    707                      ENDIF 
    708  
    709                      ! Depth of var2 observation 
    710                      profdata%var(2)%vdep(ivar2t) = & 
    711                         &                inpfiles(jj)%pdep(ij,ji) 
    712  
    713                      ! Depth of var2 observation QC 
    714                      profdata%var(2)%idqc(ivar2t) = & 
    715                         &                inpfiles(jj)%idqc(ij,ji) 
    716  
    717                      ! Depth of var2 observation QC flags 
    718                      profdata%var(2)%idqcf(:,ivar2t) = & 
    719                         &                inpfiles(jj)%idqcf(:,ij,ji) 
    720  
    721                      ! Profile index 
    722                      profdata%var(2)%nvpidx(ivar2t) = iprof 
    723  
    724                      ! Vertical index in original profile 
    725                      profdata%var(2)%nvlidx(ivar2t) = ij 
    726  
    727                      ! Profile var2 value 
    728                   IF (  ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & 
    729                     &   ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2)    )  ) THEN 
    730                         profdata%var(2)%vobs(ivar2t) = & 
    731                            &                inpfiles(jj)%pob(ij,ji,2) 
    732                         IF ( ldmod ) THEN 
    733                            profdata%var(2)%vmod(ivar2t) = & 
    734                               &                inpfiles(jj)%padd(ij,ji,1,2) 
    735                         ENDIF 
    736                         ! Count number of profile var2 data as function of type 
    737                         itypvar2( profdata%ntyp(iprof) + 1 ) = & 
    738                            & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 
    739                      ELSE 
    740                         profdata%var(2)%vobs(ivar2t) = fbrmdi 
    741                      ENDIF 
    742  
    743                      ! Profile var2 qc 
    744                      profdata%var(2)%nvqc(ivar2t) = & 
    745                         & inpfiles(jj)%ivlqc(ij,ji,2) 
    746  
    747                      ! Profile var2 qc flags 
    748                      profdata%var(2)%nvqcf(:,ivar2t) = & 
    749                         & inpfiles(jj)%ivlqcf(:,ij,ji,2) 
    750  
    751                   ENDIF 
     726                   
     727                  END DO 
    752728 
    753729               END DO loop_p 
    … …  
    763739      !----------------------------------------------------------------------- 
    764740 
    765       CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 
    766       CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 
     741      DO jvar = 1, kvars 
     742         CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 
     743      END DO 
    767744      CALL obs_mpp_sum_integer ( ip3dt,   ip3dtmpp  ) 
    768745 
    769       CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 
    770       CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 
     746      DO jvar = 1, kvars 
     747         CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 
     748      END DO 
    771749 
    772750      !----------------------------------------------------------------------- 
    … …  
    778756         WRITE(numout,'(1X,A)') '------------' 
    779757         WRITE(numout,*)  
    780          WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 
    781          WRITE(numout,'(1X,A)') '------------------------' 
    782          DO ji = 0, ntyp1770 
    783             IF ( itypvar1mpp(ji+1) > 0 ) THEN 
    784                WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    785                   & cwmonam1770(ji)(1:52),' = ', & 
    786                   & itypvar1mpp(ji+1) 
    787             ENDIF 
     758         DO jvar = 1, kvars 
     759            WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 
     760            WRITE(numout,'(1X,A)') '------------------------' 
     761            DO ji = 0, ntyp1770 
     762               IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 
     763                  WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
     764                     & cwmonam1770(ji)(1:52),' = ', & 
     765                     & itypvarmpp(ji+1,jvar) 
     766               ENDIF 
     767            END DO 
     768            WRITE(numout,'(1X,A)') & 
     769               & '---------------------------------------------------------------' 
     770            WRITE(numout,'(1X,A55,I8)') & 
     771               & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 
     772               & '             = ', ivartmpp(jvar) 
     773            WRITE(numout,'(1X,A)') & 
     774               & '---------------------------------------------------------------' 
     775            WRITE(numout,*)  
    788776         END DO 
    789          WRITE(numout,'(1X,A)') & 
    790             & '---------------------------------------------------------------' 
    791          WRITE(numout,'(1X,A55,I8)') & 
    792             & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 
    793             & '             = ', ivar1tmpp 
    794          WRITE(numout,'(1X,A)') & 
    795             & '---------------------------------------------------------------' 
    796          WRITE(numout,*)  
    797          WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 
    798          WRITE(numout,'(1X,A)') '------------------------' 
    799          DO ji = 0, ntyp1770 
    800             IF ( itypvar2mpp(ji+1) > 0 ) THEN 
    801                WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    802                   & cwmonam1770(ji)(1:52),' = ', & 
    803                   & itypvar2mpp(ji+1) 
    804             ENDIF 
     777      ENDIF 
     778 
     779      IF (ldsatt) THEN 
     780         profdata%nvprot(:)    = ip3dt 
     781         profdata%nvprotmpp(:) = ip3dtmpp 
     782      ELSE 
     783         DO jvar = 1, kvars 
     784            profdata%nvprot(jvar)    = ivart(jvar) 
     785            profdata%nvprotmpp(jvar) = ivartmpp(jvar) 
    805786         END DO 
    806          WRITE(numout,'(1X,A)') & 
    807             & '---------------------------------------------------------------' 
    808          WRITE(numout,'(1X,A55,I8)') & 
    809             & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// & 
    810             & '             = ', ivar2tmpp 
    811          WRITE(numout,'(1X,A)') & 
    812             & '---------------------------------------------------------------' 
    813          WRITE(numout,*)  
    814       ENDIF 
    815  
    816       IF (ldsatt) THEN 
    817          profdata%nvprot(1)    = ip3dt 
    818          profdata%nvprot(2)    = ip3dt 
    819          profdata%nvprotmpp(1) = ip3dtmpp 
    820          profdata%nvprotmpp(2) = ip3dtmpp 
    821       ELSE 
    822          profdata%nvprot(1)    = ivar1t 
    823          profdata%nvprot(2)    = ivar2t 
    824          profdata%nvprotmpp(1) = ivar1tmpp 
    825          profdata%nvprotmpp(2) = ivar2tmpp 
    826787      ENDIF 
    827788      profdata%nprof        = iprof 
    … …  
    830791      ! Model level search 
    831792      !----------------------------------------------------------------------- 
    832       IF ( ldvar1 ) THEN 
    833          CALL obs_level_search( jpk, gdept_1d, & 
    834             & profdata%nvprot(1), profdata%var(1)%vdep, & 
    835             & profdata%var(1)%mvk ) 
    836       ENDIF 
    837       IF ( ldvar2 ) THEN 
    838          CALL obs_level_search( jpk, gdept_1d, & 
    839             & profdata%nvprot(2), profdata%var(2)%vdep, & 
    840             & profdata%var(2)%mvk ) 
    841       ENDIF 
     793      DO jvar = 1, kvars 
     794         IF ( ldvar(jvar) ) THEN 
     795            CALL obs_level_search( jpk, gdept_1d, & 
     796               & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 
     797               & profdata%var(jvar)%mvk ) 
     798         ENDIF 
     799      END DO 
    842800 
    843801      !----------------------------------------------------------------------- 
    … …  
    852810      ! Deallocate temporary data 
    853811      !----------------------------------------------------------------------- 
    854       DEALLOCATE( ifileidx, iprofidx, zdat, clvars ) 
     812      DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) 
    855813 
    856814      !----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_read_surf.F90

    r13226 r14062  
    4040   SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & 
    4141      &                     kvars, kextr, kstp, ddobsini, ddobsend, & 
    42       &                     ldignmis, ldmod, ldnightav ) 
     42      &                     ldignmis, ldmod, ldnightav, cdvars ) 
    4343      !!--------------------------------------------------------------------- 
    4444      !! 
    … …  
    7373      REAL(dp), INTENT(IN) :: ddobsini   ! Obs. ini time in YYYYMMDD.HHMMSS 
    7474      REAL(dp), INTENT(IN) :: ddobsend   ! Obs. end time in YYYYMMDD.HHMMSS 
     75      CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 
    7576 
    7677      !! * Local declarations 
    7778      CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' 
    7879      CHARACTER(len=8) :: clrefdate 
    79       CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 
     80      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 
    8081      INTEGER :: ji 
    8182      INTEGER :: jj 
    … …  
    178179               &                ldgrid = .TRUE. ) 
    179180 
     181            IF ( inpfiles(jj)%nvar /= kvars ) THEN 
     182               CALL ctl_stop( 'Feedback format error: ', & 
     183                  &           ' unexpected number of vars in feedback file' ) 
     184            ENDIF 
     185 
    180186            IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
    181187               CALL ctl_stop( 'Model not in input data' ) 
    … …  
    184190 
    185191            IF ( jj == 1 ) THEN 
    186                ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 
     192               ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 
    187193               DO ji = 1, inpfiles(jj)%nvar 
    188                  clvars(ji) = inpfiles(jj)%cname(ji) 
     194                 clvarsin(ji) = inpfiles(jj)%cname(ji) 
     195                 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 
     196                    CALL ctl_stop( 'Feedback file variables do not match', & 
     197                        &           ' expected variable names for this type' ) 
     198                 ENDIF 
    189199               END DO 
    190200            ELSE 
    191201               DO ji = 1, inpfiles(jj)%nvar 
    192                   IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN 
     202                  IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 
    193203                     CALL ctl_stop( 'Feedback file variables not consistent', & 
    194204                        &           ' with previous files for this type' ) 
    … …  
    347357      iobs = 0 
    348358 
    349       surfdata%cvars(:)  = clvars(:) 
     359      surfdata%cvars(:)  = clvarsin(:) 
    350360 
    351361      ityp   (:) = 0 
    … …  
    480490      ! Deallocate temporary data 
    481491      !----------------------------------------------------------------------- 
    482       DEALLOCATE( ifileidx, isurfidx, zdat, clvars ) 
     492      DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) 
    483493 
    484494      !----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_write.F90

    r12933 r14062  
    8686      CHARACTER(LEN=40) :: clfname 
    8787      CHARACTER(LEN=10) :: clfiletype 
     88      CHARACTER(LEN=ilenlong) :: cllongname  ! Long name of variable 
     89      CHARACTER(LEN=ilenunit) :: clunits     ! Units of variable 
     90      CHARACTER(LEN=ilengrid) :: clgrid      ! Grid of variable 
    8891      CHARACTER(LEN=12) :: clfmt            ! writing format 
    8992      INTEGER :: idg                        ! number of digits 
    … …  
    115118      ! Find maximum level 
    116119      ilevel = 0 
    117       DO jvar = 1, 2 
     120      DO jvar = 1, profdata%nvar 
    118121         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    119122      END DO 
    … …  
    180183 
    181184      END SELECT 
     185       
     186      IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 
     187         & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 
     188         CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 
     189            &                 1 + iadd, iext, .TRUE. ) 
     190         fbdata%cname(1)      = profdata%cvars(1) 
     191         fbdata%coblong(1)    = cllongname 
     192         fbdata%cobunit(1)    = clunits 
     193         fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 
     194         fbdata%caddunit(1,1) = clunits 
     195         fbdata%cgrid(:)      = clgrid 
     196         DO je = 1, iext 
     197            fbdata%cextname(je) = pext%cdname(je) 
     198            fbdata%cextlong(je) = pext%cdlong(je,1) 
     199            fbdata%cextunit(je) = pext%cdunit(je,1) 
     200         END DO 
     201         DO ja = 1, iadd 
     202            fbdata%caddname(1+ja) = padd%cdname(ja) 
     203            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     204            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     205         END DO 
     206      ENDIF 
    182207 
    183208      fbdata%caddname(1)   = 'Hx' 
    … …  
    234259            &           krefdate = 19500101 ) 
    235260         ! Reform the profiles arrays for output 
    236          DO jvar = 1, 2 
     261         DO jvar = 1, profdata%nvar 
    237262            DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 
    238263               ik = profdata%var(jvar)%nvlidx(jk) 
    … …  
    329354      CHARACTER(LEN=40) :: clfname         ! netCDF filename 
    330355      CHARACTER(LEN=10) :: clfiletype 
     356      CHARACTER(LEN=ilenlong) :: cllongname  ! Long name of variable 
     357      CHARACTER(LEN=ilenunit) :: clunits     ! Units of variable 
     358      CHARACTER(LEN=ilengrid) :: clgrid      ! Grid of variable 
    331359      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 
    332360      CHARACTER(LEN=12) :: clfmt           ! writing format 
    … …  
    354382      SELECT CASE ( TRIM(surfdata%cvars(1)) ) 
    355383      CASE('SLA') 
     384          
     385         ! SLA needs special treatment because of MDT, so is all done here 
     386         ! Other variables are done more generically 
     387         ! No climatology for SLA, MDT is our best estimate of that and is already output. 
    356388 
    357389         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
    … …  
    384416      CASE('SST') 
    385417 
     418         clfiletype = 'sstfb' 
     419         cllongname = 'Sea surface temperature' 
     420         clunits    = 'Degree centigrade' 
     421         clgrid     = 'T' 
     422          
     423      CASE('ICECONC') 
     424 
     425         clfiletype = 'sicfb' 
     426         cllongname = 'Sea ice concentration' 
     427         clunits    = 'Fraction' 
     428         clgrid     = 'T' 
     429 
     430      CASE('SSS') 
     431 
     432         clfiletype = 'sssfb' 
     433         cllongname = 'Sea surface salinity' 
     434         clunits    = 'psu' 
     435         clgrid     = 'T' 
     436 
     437      CASE DEFAULT 
     438 
     439         CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 
     440 
     441      END SELECT 
     442 
     443      ! SLA needs special treatment because of MDT, so is done above 
     444      ! Remaining variables treated more generically 
     445 
     446      IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 
     447       
    386448         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
    387449            &                 1 + iadd, iext, .TRUE. ) 
    388450 
    389          clfiletype = 'sstfb' 
    390451         fbdata%cname(1)      = surfdata%cvars(1) 
    391          fbdata%coblong(1)    = 'Sea surface temperature' 
    392          fbdata%cobunit(1)    = 'Degree centigrade' 
     452         fbdata%coblong(1)    = cllongname 
     453         fbdata%cobunit(1)    = clunits 
    393454         DO je = 1, iext 
    394455            fbdata%cextname(je) = pext%cdname(je) 
    395456            fbdata%cextlong(je) = pext%cdlong(je,1) 
    396457            fbdata%cextunit(je) = pext%cdunit(je,1) 
    397          END DO 
    398          fbdata%caddlong(1,1) = 'Model interpolated SST' 
    399          fbdata%caddunit(1,1) = 'Degree centigrade' 
    400          fbdata%cgrid(1)      = 'T' 
     458         END DO         
     459         IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 
     460            fbdata%caddlong(1,1) = 'Model interpolated ICE' 
     461         ELSE 
     462            fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 
     463         ENDIF 
     464         fbdata%caddunit(1,1) = clunits 
     465         fbdata%cgrid(1)      = clgrid 
    401466         DO ja = 1, iadd 
    402467            fbdata%caddname(1+ja) = padd%cdname(ja) 
    … …  
    404469            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    405470         END DO 
    406  
    407       CASE('ICECONC') 
    408  
    409          CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
    410             &                 1 + iadd, iext, .TRUE. ) 
    411  
    412          clfiletype = 'sicfb' 
    413          fbdata%cname(1)      = surfdata%cvars(1) 
    414          fbdata%coblong(1)    = 'Sea ice' 
    415          fbdata%cobunit(1)    = 'Fraction' 
    416          DO je = 1, iext 
    417             fbdata%cextname(je) = pext%cdname(je) 
    418             fbdata%cextlong(je) = pext%cdlong(je,1) 
    419             fbdata%cextunit(je) = pext%cdunit(je,1) 
    420          END DO 
    421          fbdata%caddlong(1,1) = 'Model interpolated ICE' 
    422          fbdata%caddunit(1,1) = 'Fraction' 
    423          fbdata%cgrid(1)      = 'T' 
    424          DO ja = 1, iadd 
    425             fbdata%caddname(1+ja) = padd%cdname(ja) 
    426             fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    427             fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    428          END DO 
    429  
    430       CASE('SSS') 
    431  
    432          CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
    433             &                 1 + iadd, iext, .TRUE. ) 
    434  
    435          clfiletype = 'sssfb' 
    436          fbdata%cname(1)      = surfdata%cvars(1) 
    437          fbdata%coblong(1)    = 'Sea surface salinity' 
    438          fbdata%cobunit(1)    = 'psu' 
    439          DO je = 1, iext 
    440             fbdata%cextname(je) = pext%cdname(je) 
    441             fbdata%cextlong(je) = pext%cdlong(je,1) 
    442             fbdata%cextunit(je) = pext%cdunit(je,1) 
    443          END DO 
    444          fbdata%caddlong(1,1) = 'Model interpolated SSS' 
    445          fbdata%caddunit(1,1) = 'psu' 
    446          fbdata%cgrid(1)      = 'T' 
    447          DO ja = 1, iadd 
    448             fbdata%caddname(1+ja) = padd%cdname(ja) 
    449             fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    450             fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    451          END DO 
    452  
    453       CASE DEFAULT 
    454  
    455          CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 
    456  
    457       END SELECT 
     471      ENDIF 
    458472 
    459473      fbdata%caddname(1)   = 'Hx' 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcapr.F90

    r14037 r14062  
    148148         !                                      ! ---------------------------------------- ! 
    149149         !                                            !* Restart: read in restart file 
    150          IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN  
     150         IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN  
    151151            IF(lwp) WRITE(numout,*) 'sbc_apr:   ssh_ibb read in the restart file' 
    152152            CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb )   ! before inv. barometer ssh 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcice_cice.F90

    r13295 r14062  
    1212   USE oce             ! ocean dynamics and tracers 
    1313   USE dom_oce         ! ocean space and time domain 
    14 # if ! defined key_qco 
    15    USE domvvl 
     14# if defined key_qco 
     15   USE domqco         ! Variable volume 
    1616# else 
    17    USE domqco 
     17   USE domvvl         ! Variable volume 
    1818# endif 
    1919   USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi 
    … …  
    238238!!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 
    239239#if defined key_qco 
    240             IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 
     240            IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm )   ! interpolation scale factor, depth and water column 
    241241#else 
    242242            IF( .NOT.ln_linssh ) THEN 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcmod.F90

    r14044 r14062  
    523523      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    524524         !                                             ! ---------------------------------------- ! 
    525          IF( ln_rstart .AND.    &                               !* Restart: read in restart file 
    526             & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 
    527             IF(lwp) WRITE(numout,*) '          nit000-1 surface forcing fields red in the restart file' 
    528             CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b )   ! before i-stress  (U-point) 
    529             CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b )   ! before j-stress  (V-point) 
    530             CALL iom_get( numror, jpdom_auto,  'qns_b',  qns_b )   ! before non solar heat flux (T-point) 
    531             ! The 3D heat content due to qsr forcing is treated in traqsr 
    532             ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b  ) ! before     solar heat flux (T-point) 
    533             CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b  )    ! before     freshwater flux (T-point) 
     525         IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN            !* Restart: read in restart file 
     526            IF(lwp) WRITE(numout,*) '          nit000-1 surface forcing fields read in the restart file' 
     527            CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b )   ! i-stress 
     528            CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b )   ! j-stress 
     529            CALL iom_get( numror, jpdom_auto,  'qns_b',  qns_b )   ! non solar heat flux 
     530            CALL iom_get( numror, jpdom_auto,  'emp_b',  emp_b )   ! freshwater flux 
     531            ! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr 
    534532            ! To ensure restart capability with 3.3x/3.4 restart files    !! to be removed in v3.6 
    535533            IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN 
    … …  
    566564      !                                                ! ---------------------------------------- ! 
    567565      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    568          CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
    569          CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    570          CALL iom_put( "saltflx", sfx  )                        ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) 
    571          CALL iom_put( "fmmflx", fmmflx  )                      ! Freezing-melting water flux 
    572          CALL iom_put( "qt"    , qns  + qsr )                   ! total heat flux 
    573          CALL iom_put( "qns"   , qns        )                   ! solar heat flux 
    574          CALL iom_put( "qsr"   ,       qsr  )                   ! solar heat flux 
     566         CALL iom_put( "empmr"  , emp   - rnf )                ! upward water flux 
     567         CALL iom_put( "empbmr" , emp_b - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
     568         CALL iom_put( "saltflx", sfx         )                ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) 
     569         CALL iom_put( "fmmflx" , fmmflx      )                ! Freezing-melting water flux 
     570         CALL iom_put( "qt"     , qns + qsr   )                ! total heat flux 
     571         CALL iom_put( "qns"    , qns         )                ! solar heat flux 
     572         CALL iom_put( "qsr"    ,       qsr   )                ! solar heat flux 
    575573         IF( nn_ice > 0 .OR. ll_opa )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction 
    576          CALL iom_put( "taum"  , taum       )                   ! wind stress module 
    577          CALL iom_put( "wspd"  , wndm       )                   ! wind speed  module over free ocean or leads in presence of sea-ice 
    578          CALL iom_put( "qrp", qrp )                             ! heat flux damping 
    579          CALL iom_put( "erp", erp )                             ! freshwater flux damping 
     574         CALL iom_put( "taum"   , taum        )                ! wind stress module 
     575         CALL iom_put( "wspd"   , wndm        )                ! wind speed  module over free ocean or leads in presence of sea-ice 
     576         CALL iom_put( "qrp"    , qrp         )                ! heat flux damping 
     577         CALL iom_put( "erp"    , erp         )                ! freshwater flux damping 
    580578      ENDIF 
    581579      ! 
    582580      IF(sn_cfctl%l_prtctl) THEN     ! print mean trends (used for debugging) 
    583          CALL prt_ctl(tab2d_1=fr_i             , clinfo1=' fr_i     - : ', mask1=tmask ) 
    584          CALL prt_ctl(tab2d_1=(emp-rnf)        , clinfo1=' emp-rnf  - : ', mask1=tmask ) 
    585          CALL prt_ctl(tab2d_1=(sfx-rnf)        , clinfo1=' sfx-rnf  - : ', mask1=tmask ) 
    586          CALL prt_ctl(tab2d_1=qns              , clinfo1=' qns      - : ', mask1=tmask ) 
    587          CALL prt_ctl(tab2d_1=qsr              , clinfo1=' qsr      - : ', mask1=tmask ) 
    588          CALL prt_ctl(tab3d_1=tmask            , clinfo1=' tmask    - : ', mask1=tmask, kdim=jpk ) 
     581         CALL prt_ctl(tab2d_1=fr_i                , clinfo1=' fr_i     - : ', mask1=tmask ) 
     582         CALL prt_ctl(tab2d_1=(emp-rnf)           , clinfo1=' emp-rnf  - : ', mask1=tmask ) 
     583         CALL prt_ctl(tab2d_1=(sfx-rnf)           , clinfo1=' sfx-rnf  - : ', mask1=tmask ) 
     584         CALL prt_ctl(tab2d_1=qns                 , clinfo1=' qns      - : ', mask1=tmask ) 
     585         CALL prt_ctl(tab2d_1=qsr                 , clinfo1=' qsr      - : ', mask1=tmask ) 
     586         CALL prt_ctl(tab3d_1=tmask               , clinfo1=' tmask    - : ', mask1=tmask, kdim=jpk ) 
    589587         CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst      - : ', mask1=tmask, kdim=1   ) 
    590588         CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss      - : ', mask1=tmask, kdim=1   ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcrnf.F90

    r14044 r14062  
    157157      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    158158         !                                             ! ---------------------------------------- ! 
    159          IF( ln_rstart .AND.    &                               !* Restart: read in restart file 
    160             & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 
     159         IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN         !* Restart: read in restart file 
    161160            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields red in the restart file', lrxios 
    162             CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b )     ! before runoff 
     161            CALL iom_get( numror, jpdom_auto, 'rnf_b'   , rnf_b                 )   ! before runoff 
    163162            CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) )   ! before heat content of runoff 
    164163            CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) )   ! before salinity content of runoff 
    165          ELSE                                                   !* no restart: set from nit000 values 
     164         ELSE                                                !* no restart: set from nit000 values 
    166165            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    167166            rnf_b    (:,:  ) = rnf    (:,:  ) 
    … …  
    176175            &                    'at it= ', kt,' date= ', ndastp 
    177176         IF(lwp) WRITE(numout,*) '~~~~' 
    178          CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 
     177         CALL iom_rstput( kt, nitrst, numrow, 'rnf_b'   , rnf                ) 
    179178         CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 
    180179         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traatf.F90

    r14037 r14062  
    117117      IF( l_trdtra )   THEN                     
    118118         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    119          ztrdt(:,:,jpk) = 0._wp 
    120          ztrds(:,:,jpk) = 0._wp 
     119         ztrdt(:,:,:) = 0._wp 
     120         ztrds(:,:,:) = 0._wp 
    121121         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend  
    122122            CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traatf_qco.F90

    r14037 r14062  
    1 MODULE traatfqco 
     1MODULE traatf_qco 
    22   !!====================================================================== 
    3    !!                       ***  MODULE  traatfqco  *** 
     3   !!                       ***  MODULE  traatf_qco  *** 
    44   !! Ocean active tracers:  Asselin time filtering for temperature and salinity 
    55   !!====================================================================== 
    … …  
    4545   USE prtctl          ! Print control 
    4646   USE timing          ! Timing 
    47 #if defined key_agrif 
    48    USE agrif_oce_interp 
    49 #endif 
    5047 
    5148   IMPLICIT NONE 
    … …  
    149146         ENDIF 
    150147         ! 
    151          CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1. ) 
    152  
     148         CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 
     149         ! 
    153150      ENDIF 
    154151      ! 
    … …  
    370367 
    371368   !!====================================================================== 
    372 END MODULE traatfqco 
     369END MODULE traatf_qco 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/tramle.F90

    r14037 r14062  
    2020   USE lib_mpp        ! MPP library 
    2121   USE lbclnk         ! lateral boundary condition / mpp link 
     22 
     23   ! where OSMOSIS_OBL is used with integrated FK 
     24   USE zdf_oce, ONLY : ln_zdfosm 
     25   USE zdfosm, ONLY  : ln_osm_mle, hmle, dbdx_mle, dbdy_mle, mld_prof 
    2226 
    2327   IMPLICIT NONE 
    … …  
    99103      !!---------------------------------------------------------------------- 
    100104      ! 
    101       !                                      !==  MLD used for MLE  ==! 
    102       !                                                ! compute from the 10m density to deal with the diurnal cycle 
    103       DO_2D( 1, 1, 1, 1 ) 
    104          inml_mle(ji,jj) = mbkt(ji,jj) + 1                    ! init. to number of ocean w-level (T-level + 1) 
    105       END_2D 
    106       IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    107          DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
    108             IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
     105      ! 
     106      IF(ln_osm_mle.and.ln_zdfosm) THEN 
     107         ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 )                  ! max level of the computation 
     108         ! 
     109         ! 
     110         SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts 
     111         CASE ( 0 )                                               != min of the 2 neighbour MLDs 
     112            DO_2D( 1, 0, 1, 0 ) 
     113               zhu(ji,jj) = MIN( hmle(ji+1,jj), hmle(ji,jj) ) 
     114               zhv(ji,jj) = MIN( hmle(ji,jj+1), hmle(ji,jj) ) 
     115            END_2D 
     116         CASE ( 1 )                                               != average of the 2 neighbour MLDs 
     117            DO_2D( 1, 0, 1, 0 ) 
     118               zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) 
     119               zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) 
     120            END_2D 
     121         CASE ( 2 )                                               != max of the 2 neighbour MLDs 
     122            DO_2D( 1, 0, 1, 0 ) 
     123               zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) 
     124               zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) 
     125            END_2D 
     126         END SELECT 
     127         IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation 
     128            DO_2D( 1, 0, 1, 0 ) 
     129               zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2u(ji,jj)                                            & 
     130                    &           * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
     131                    &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
     132               ! 
     133               zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1v(ji,jj)                                            & 
     134                    &           * dbdy_mle(ji,jj)  * MIN( 111.e3_wp , e2v(ji,jj) )   & 
     135                    &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
     136            END_2D 
     137            ! 
     138         ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 
     139            DO_2D( 1, 0, 1, 0 ) 
     140               zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2u(ji,jj)               & 
     141                    &                  * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) 
     142               ! 
     143               zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1v(ji,jj)               & 
     144                    &                  * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) 
     145            END_2D 
     146         ENDIF 
     147 
     148      ELSE !do not use osn_mle 
     149         !                                      !==  MLD used for MLE  ==! 
     150         !                                                ! compute from the 10m density to deal with the diurnal cycle 
     151         DO_2D( 1, 1, 1, 1 ) 
     152            inml_mle(ji,jj) = mbkt(ji,jj) + 1                    ! init. to number of ocean w-level (T-level + 1) 
     153         END_2D 
     154         IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
     155           DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
     156              IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
     157           END_3D 
     158         ENDIF 
     159         ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 )                  ! max level of the computation 
     160         ! 
     161         ! 
     162         zmld(:,:) = 0._wp                      !==   Horizontal shape of the MLE  ==! 
     163         zbm (:,:) = 0._wp 
     164         zn2 (:,:) = 0._wp 
     165         DO_3D( 1, 1, 1, 1, 1, ikmax )                    ! MLD and mean buoyancy and N2 over the mixed layer 
     166            zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
     167            zmld(ji,jj) = zmld(ji,jj) + zc 
     168            zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 
     169            zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
    109170         END_3D 
    110       ENDIF 
    111       ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 )                  ! max level of the computation 
    112       ! 
    113       ! 
    114       zmld(:,:) = 0._wp                      !==   Horizontal shape of the MLE  ==! 
    115       zbm (:,:) = 0._wp 
    116       zn2 (:,:) = 0._wp 
    117       DO_3D( 1, 1, 1, 1, 1, ikmax )                    ! MLD and mean buoyancy and N2 over the mixed layer 
    118          zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
    119          zmld(ji,jj) = zmld(ji,jj) + zc 
    120          zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 
    121          zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
    122       END_3D 
    123  
    124       SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts 
    125       CASE ( 0 )                                               != min of the 2 neighbour MLDs 
    126          DO_2D( 1, 0, 1, 0 ) 
    127             zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
    128             zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
     171    
     172         SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts 
     173         CASE ( 0 )                                               != min of the 2 neighbour MLDs 
     174            DO_2D( 1, 0, 1, 0 ) 
     175               zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
     176               zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
     177            END_2D 
     178         CASE ( 1 )                                               != average of the 2 neighbour MLDs 
     179            DO_2D( 1, 0, 1, 0 ) 
     180               zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
     181               zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
     182            END_2D 
     183         CASE ( 2 )                                               != max of the 2 neighbour MLDs 
     184            DO_2D( 1, 0, 1, 0 ) 
     185               zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
     186               zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
     187            END_2D 
     188         END SELECT 
     189         !                                                ! convert density into buoyancy 
     190         DO_2D( 1, 1, 1, 1 ) 
     191            zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 
    129192         END_2D 
    130       CASE ( 1 )                                               != average of the 2 neighbour MLDs 
    131          DO_2D( 1, 0, 1, 0 ) 
    132             zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
    133             zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
    134          END_2D 
    135       CASE ( 2 )                                               != max of the 2 neighbour MLDs 
    136          DO_2D( 1, 0, 1, 0 ) 
    137             zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
    138             zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
    139          END_2D 
    140       END SELECT 
    141       !                                                ! convert density into buoyancy 
    142       DO_2D( 1, 1, 1, 1 ) 
    143          zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 
    144       END_2D 
    145       ! 
    146       ! 
    147       !                                      !==  Magnitude of the MLE stream function  ==! 
    148       ! 
    149       !                 di[bm]  Ds 
    150       ! Psi = Ce  H^2 ---------------- e2u  mu(z)   where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) 
    151       !                  e1u   Lf fu                      and the e2u for the "transport" 
    152       !                                                      (not *e3u as divided by e3u at the end) 
    153       ! 
    154       IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation 
    155          DO_2D( 1, 0, 1, 0 ) 
    156             zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
    157                &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
    158                &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
     193         ! 
     194         ! 
     195         !                                      !==  Magnitude of the MLE stream function  ==! 
     196         ! 
     197         !                 di[bm]  Ds 
     198         ! Psi = Ce  H^2 ---------------- e2u  mu(z)   where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) 
     199         !                  e1u   Lf fu                      and the e2u for the "transport" 
     200         !                                                      (not *e3u as divided by e3u at the end) 
     201         ! 
     202         IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation 
     203            DO_2D( 1, 0, 1, 0 ) 
     204               zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
     205                    &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
     206                    &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
    159207               ! 
    160             zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
    161                &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
    162                &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
    163          END_2D 
    164          ! 
    165       ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 
    166          DO_2D( 1, 0, 1, 0 ) 
    167             zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
    168                &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
     208               zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
     209                    &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
     210                    &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
     211            END_2D 
     212            ! 
     213         ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 
     214            DO_2D( 1, 0, 1, 0 ) 
     215               zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
     216                    &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
    169217               ! 
    170             zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
    171                &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
    172          END_2D 
    173       ENDIF 
    174       ! 
    175       IF( nn_conv == 1 ) THEN              ! No MLE in case of convection 
    176          DO_2D( 1, 0, 1, 0 ) 
    177             IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
    178             IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
    179          END_2D 
    180       ENDIF 
    181       ! 
    182       !                                      !==  structure function value at uw- and vw-points  ==! 
    183       DO_2D( 1, 0, 1, 0 ) 
    184          zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
    185          zhv(ji,jj) = 1._wp / zhv(ji,jj) 
    186       END_2D 
    187       ! 
    188       zpsi_uw(:,:,:) = 0._wp 
    189       zpsi_vw(:,:,:) = 0._wp 
    190       ! 
     218               zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
     219                    &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
     220            END_2D 
     221         ENDIF 
     222         ! 
     223         IF( nn_conv == 1 ) THEN              ! No MLE in case of convection 
     224            DO_2D( 1, 0, 1, 0 ) 
     225               IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
     226               IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
     227            END_2D 
     228         ENDIF 
     229         ! 
     230      ENDIF  ! end of ln_osm_mle conditional 
     231    !                                      !==  structure function value at uw- and vw-points  ==! 
     232    DO_2D( 1, 0, 1, 0 ) 
     233       zhu(ji,jj) = 1._wp / MAX(zhu(ji,jj), rsmall)                   ! hu --> 1/hu 
     234       zhv(ji,jj) = 1._wp / MAX(zhv(ji,jj), rsmall)  
     235    END_2D 
     236    ! 
     237    zpsi_uw(:,:,:) = 0._wp 
     238    zpsi_vw(:,:,:) = 0._wp 
     239    ! 
    191240      DO_3D( 1, 0, 1, 0, 2, ikmax )                ! start from 2 : surface value = 0 
    192241         zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 
    … …  
    220269         ENDIF 
    221270         ! 
    222          DO_2D( 0, 0, 0, 0 ) 
    223             zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
    224          END_2D 
     271         IF (ln_osm_mle.and.ln_zdfosm) THEN 
     272            DO_2D( 0, 0, 0, 0 ) 
     273               zLf_NH(ji,jj) = SQRT( rb_c * hmle(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
     274            END_2D 
     275         ELSE 
     276            DO_2D( 0, 0, 0, 0 ) 
     277               zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
     278            END_2D 
     279         ENDIF 
    225280         ! 
    226281         ! divide by cross distance to give streamfunction with dimensions m^2/s 
    … …  
    239294      ! 
    240295   END SUBROUTINE tra_mle_trp 
    241  
    242296 
    243297   SUBROUTINE tra_mle_init 
    … …  
    301355            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    302356            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    303             DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )                      ! "coriolis+ time^-1" at u- & v-points 
     357            DO_2D( 0, 1, 0, 1 )                      ! "coriolis+ time^-1" at u- & v-points 
    304358               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    305359               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
    … …  
    307361               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    308362            END_2D 
    309             IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
     363            CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
    310364            ! 
    311365         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traqsr.F90

    r14037 r14062  
    144144 
    145145      IF( kt == nit000 ) THEN          !==  1st time step  ==! 
    146          IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0  .AND. .NOT.l_1st_euler ) THEN    ! read in restart 
     146         IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN    ! read in restart 
    147147            z1_2 = 0.5_wp 
    148148            IF( ntile == 0 .OR. ntile == 1 )  THEN                        ! Do only on the first tile 
    … …  
    150150               CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b )   ! before heat content trend due to Qsr flux 
    151151            ENDIF 
    152          ELSE                                           ! No restart or restart not found: Euler forward time stepping 
     152         ELSE                                           ! No restart or Euler forward at 1st time step 
    153153            z1_2 = 1._wp 
    154154            DO_3D( isj, iej, isi, iei, 1, jpk ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/trasbc.F90

    r14037 r14062  
    7272      !!              - send trends to trdtra module for further diagnostics(l_trdtra=T) 
    7373      !!---------------------------------------------------------------------- 
    74       INTEGER,                                   INTENT(in   ) :: kt         ! ocean time-step index 
    75       INTEGER,                                   INTENT(in   ) :: Kmm, Krhs  ! time level indices 
    76       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
     74      INTEGER,                                   INTENT(in   ) ::   kt         ! ocean time-step index 
     75      INTEGER,                                   INTENT(in   ) ::   Kmm, Krhs  ! time level indices 
     76      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) ::   pts        ! active tracers and RHS of tracer Eq. 
    7777      ! 
    7878      INTEGER  ::   ji, jj, jk, jn               ! dummy loop indices 
    … …  
    117117      !                             !==  Set before sbc tracer content fields  ==! 
    118118      IF( kt == nit000 ) THEN             !* 1st time-step 
    119          IF( ln_rstart .AND.    &               ! Restart: read in restart file 
    120               & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
     119         IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN      ! Restart: read in restart file 
    121120            zfact = 0.5_wp 
    122121            IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
    … …  
    126125               CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) )   ! before salt content sbc trend 
    127126            ENDIF 
    128          ELSE                                   ! No restart or restart not found: Euler forward time stepping 
     127         ELSE                                             ! No restart or restart not found: Euler forward time stepping 
    129128            zfact = 1._wp 
    130129            DO_2D( isj, iej, isi, iei ) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRD/trd_oce.F90

    r10068 r14062  
    3333# endif 
    3434   !                                                  !!!* Active tracers trends indexes 
    35    INTEGER, PUBLIC, PARAMETER ::   jptot_tra  = 20     !: Total trend nb: change it when adding/removing one indice below 
     35   INTEGER, PUBLIC, PARAMETER ::   jptot_tra  = 21     !: Total trend nb: change it when adding/removing one indice below 
    3636   !                               ===============     !   
    3737   INTEGER, PUBLIC, PARAMETER ::   jptra_xad  =  1     !: x- horizontal advection 
    … …  
    4646   INTEGER, PUBLIC, PARAMETER ::   jptra_bbc  = 10     !: Bottom Boundary Condition (geoth. heating)  
    4747   INTEGER, PUBLIC, PARAMETER ::   jptra_bbl  = 11     !: Bottom Boundary Layer (diffusive and/or advective) 
     48   INTEGER, PUBLIC, PARAMETER ::   jptra_osm  = 21     !: Non-local terms from OSMOSIS OBL model 
    4849   INTEGER, PUBLIC, PARAMETER ::   jptra_npc  = 12     !: non-penetrative convection treatment 
    4950   INTEGER, PUBLIC, PARAMETER ::   jptra_dmp  = 13     !: internal restoring (damping) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/USR/usrdef_istate.F90

    r14037 r14062  
    77   !! User defined : set the initial state of a user configuration 
    88   !!====================================================================== 
    9    !! History :  4.0 ! 2016-03  (S. Flavoni) Original code 
     9   !! History :  4.0  ! 2016-03  (S. Flavoni) Original code 
     10   !!                 ! 2020-11  (S. Techene, G. Madec) separate tsuv from ssh 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2223   PRIVATE 
    2324 
    24    PUBLIC   usr_def_istate   ! called in istate.F90 
     25   PUBLIC   usr_def_istate       ! called in istate.F90 
     26   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
    2527 
    2628   !! * Substitutions 
    … …  
    3335CONTAINS 
    3436   
    35    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     37   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3638      !!---------------------------------------------------------------------- 
    3739      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    4850      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    4951      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    50       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5152      ! 
    5253      INTEGER :: ji, jj, jk  ! dummy loop indices 
    … …  
    5960      pu  (:,:,:) = 0._wp           ! ocean at rest 
    6061      pv  (:,:,:) = 0._wp 
    61       pssh(:,:)   = 0._wp 
    6262      ! 
    6363      DO_3D( 1, 1, 1, 1, 1, jpk )   ! horizontally uniform T & S profiles 
    … …  
    8080   END SUBROUTINE usr_def_istate 
    8181 
     82    
     83   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     84      !!---------------------------------------------------------------------- 
     85      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     86      !!  
     87      !! ** Purpose :   Initialization of ssh 
     88      !! 
     89      !! ** Method  :   Set ssh as null, ptmask is required for test cases 
     90      !!---------------------------------------------------------------------- 
     91      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     92      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     93      !!---------------------------------------------------------------------- 
     94      ! 
     95      IF(lwp) WRITE(numout,*) 
     96      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : GYRE configuration, analytical definition of initial state' 
     97      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~   Ocean at rest, ssh is zero' 
     98      ! 
     99      ! Sea level: 
     100      pssh(:,:) = 0._wp 
     101      ! 
     102   END SUBROUTINE usr_def_istate_ssh 
     103 
    82104   !!====================================================================== 
    83105END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfddm.F90

    r14037 r14062  
    3131   !! * Substitutions 
    3232#  include "do_loop_substitute.h90" 
     33#  include "domzgr_substitute.h90" 
    3334   !!---------------------------------------------------------------------- 
    3435   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfosm.F90

    r14037 r14062  
    2525   !!            (12) Replace zwstrl with zvstr in calculation of eddy viscosity. 
    2626   !! 27/09/2017 (13) Calculate Stokes drift and Stokes penetration depth from wave information 
    27    !!            (14) Bouyancy flux due to entrainment changed to include contribution from shear turbulence (for testing commented out). 
     27   !!            (14) Buoyancy flux due to entrainment changed to include contribution from shear turbulence. 
    2828   !! 28/09/2017 (15) Calculation of Stokes drift moved into separate do-loops to allow for different options for the determining the Stokes drift to be added. 
    2929   !!            (16) Calculation of Stokes drift from windspeed for PM spectrum (for testing, commented out) 
    3030   !!            (17) Modification to Langmuir velocity scale to include effects due to the Stokes penetration depth (for testing, commented out) 
     31   !! ??/??/2018 (18) Revision to code structure, selected using key_osmldpth1. Inline code moved into subroutines. Changes to physics made, 
     32   !!                  (a) Pycnocline temperature and salinity profies changed for unstable layers 
     33   !!                  (b) The stable OSBL depth parametrization changed. 
     34   !! 16/05/2019 (19) Fox-Kemper parametrization of restratification through mixed layer eddies added to revised code. 
     35   !! 23/05/19   (20) Old code where key_osmldpth1` is *not* set removed, together with the key key_osmldpth1 
    3136   !!---------------------------------------------------------------------- 
    3237 
    … …  
    4045   !!   trc_osm       : compute and add to the passive tracer trend the non-local flux (TBD) 
    4146   !!   dyn_osm       : compute and add to u & v trensd the non-local flux 
     47   !! 
     48   !! Subroutines in revised code. 
    4249   !!---------------------------------------------------------------------- 
    4350   USE oce            ! ocean dynamics and active tracers 
    … …  
    6976   PUBLIC   tra_osm       ! routine called by step.F90 
    7077   PUBLIC   trc_osm       ! routine called by trcstp.F90 
    71    PUBLIC   dyn_osm       ! routine called by 'step.F90' 
     78   PUBLIC   dyn_osm       ! routine called by step.F90 
     79 
     80   PUBLIC   ln_osm_mle    ! logical needed by tra_mle_init in tramle.F90 
    7281 
    7382   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghamu    !: non-local u-momentum flux 
    … …  
    7786   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   etmean   !: averaging operator for avt 
    7887   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbl      !: boundary layer depth 
    79    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbli     !: intial boundary layer depth for stable blayer 
     88   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dh       ! depth of pycnocline 
     89   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hml      ! ML depth 
    8090   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dstokes  !: penetration depth of the Stokes drift. 
     91 
     92   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)           ::   r1_ft    ! inverse of the modified Coriolis parameter at t-pts 
     93   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hmle     ! Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization 
     94   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dbdx_mle ! zonal buoyancy gradient in ML 
     95   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dbdy_mle ! meridional buoyancy gradient in ML 
     96   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   mld_prof ! level of base of MLE layer. 
    8197 
    8298   !                      !!** Namelist  namzdf_osm  ** 
    8399   LOGICAL  ::   ln_use_osm_la      ! Use namelist  rn_osm_la 
     100 
     101   LOGICAL  ::   ln_osm_mle           !: flag to activate the Mixed Layer Eddy (MLE) parameterisation 
     102 
    84103   REAL(wp) ::   rn_osm_la          ! Turbulent Langmuir number 
    85104   REAL(wp) ::   rn_osm_dstokes     ! Depth scale of Stokes drift 
     105   REAL(wp) ::   rn_zdfosm_adjust_sd = 1.0 ! factor to reduce Stokes drift by 
     106   REAL(wp) ::   rn_osm_hblfrac = 0.1! for nn_osm_wave = 3/4 specify fraction in top of hbl 
     107   LOGICAL  ::   ln_zdfosm_ice_shelter      ! flag to activate ice sheltering 
    86108   REAL(wp) ::   rn_osm_hbl0 = 10._wp       ! Initial value of hbl for 1D runs 
    87109   INTEGER  ::   nn_ave             ! = 0/1 flag for horizontal average on avt 
    88110   INTEGER  ::   nn_osm_wave = 0    ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into sbcwave 
     111   INTEGER  ::   nn_osm_SD_reduce   ! = 0/1/2 flag for getting effective stokes drift from surface value 
    89112   LOGICAL  ::   ln_dia_osm         ! Use namelist  rn_osm_la 
    90113 
    … …  
    96119   REAL(wp) ::   rn_difconv = 1._wp     ! diffusivity when unstable below BL  (m2/s) 
    97120 
     121! OSMOSIS mixed layer eddy parametrization constants 
     122   INTEGER  ::   nn_osm_mle             ! = 0/1 flag for horizontal average on avt 
     123   REAL(wp) ::   rn_osm_mle_ce           ! MLE coefficient 
     124   !                                        ! parameters used in nn_osm_mle = 0 case 
     125   REAL(wp) ::   rn_osm_mle_lf               ! typical scale of mixed layer front 
     126   REAL(wp) ::   rn_osm_mle_time             ! time scale for mixing momentum across the mixed layer 
     127   !                                        ! parameters used in nn_osm_mle = 1 case 
     128   REAL(wp) ::   rn_osm_mle_lat              ! reference latitude for a 5 km scale of ML front 
     129   LOGICAL  ::   ln_osm_hmle_limit           ! If true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld 
     130   REAL(wp) ::   rn_osm_hmle_limit           ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld 
     131   REAL(wp) ::   rn_osm_mle_rho_c        ! Density criterion for definition of MLD used by FK 
     132   REAL(wp) ::   r5_21 = 5.e0 / 21.e0   ! factor used in mle streamfunction computation 
     133   REAL(wp) ::   rb_c                   ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld 
     134   REAL(wp) ::   rc_f                   ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case 
     135   REAL(wp) ::   rn_osm_mle_thresh          ! Threshold buoyancy for deepening of MLE layer below OSBL base. 
     136   REAL(wp) ::   rn_osm_bl_thresh          ! Threshold buoyancy for deepening of OSBL base. 
     137   REAL(wp) ::   rn_osm_mle_tau             ! Adjustment timescale for MLE. 
     138 
     139 
    98140   !                                    !!! ** General constants  ** 
    99    REAL(wp) ::   epsln   = 1.0e-20_wp   ! a small positive number 
     141   REAL(wp) ::   epsln   = 1.0e-20_wp   ! a small positive number to ensure no div by zero 
     142   REAL(wp) ::   depth_tol = 1.0e-6_wp  ! a small-ish positive number to give a hbl slightly shallower than gdepw 
    100143   REAL(wp) ::   pthird  = 1._wp/3._wp  ! 1/3 
    101144   REAL(wp) ::   p2third = 2._wp/3._wp  ! 2/3 
    … …  
    118161      !!                 ***  FUNCTION zdf_osm_alloc  *** 
    119162      !!---------------------------------------------------------------------- 
    120      ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), & 
    121           &      hbl(jpi,jpj)    ,  hbli(jpi,jpj)    , dstokes(jpi, jpj) ,                     & 
    122           &   etmean(jpi,jpj,jpk),  STAT= zdf_osm_alloc ) 
     163     ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk),ghams(jpi,jpj,jpk), & 
     164          &       hbl(jpi,jpj), dh(jpi,jpj), hml(jpi,jpj), dstokes(jpi, jpj), & 
     165          &       etmean(jpi,jpj,jpk), STAT= zdf_osm_alloc ) 
     166 
     167     ALLOCATE(  hmle(jpi,jpj), r1_ft(jpi,jpj), dbdx_mle(jpi,jpj), dbdy_mle(jpi,jpj), & 
     168          &       mld_prof(jpi,jpj), STAT= zdf_osm_alloc ) 
     169 
     170     CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) 
    123171     IF( zdf_osm_alloc /= 0 )   CALL ctl_warn('zdf_osm_alloc: failed to allocate zdf_osm arrays') 
    124      CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) 
     172 
    125173   END FUNCTION zdf_osm_alloc 
    126174 
    … …  
    166214      !! 
    167215      INTEGER ::   ji, jj, jk                   ! dummy loop indices 
     216 
     217      INTEGER ::   jl                   ! dummy loop indices 
     218 
    168219      INTEGER ::   ikbot, jkmax, jkm1, jkp2     ! 
    169220 
    … …  
    196247      REAL(wp), DIMENSION(jpi,jpj) :: zwbav     ! Buoyancy flux - bl average 
    197248      REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent   ! Buoyancy entrainment flux 
     249      REAL(wp), DIMENSION(jpi,jpj) :: zwb_min 
     250 
     251 
     252      REAL(wp), DIMENSION(jpi,jpj) :: zwb_fk_b  ! MLE buoyancy flux averaged over OSBL 
     253      REAL(wp), DIMENSION(jpi,jpj) :: zwb_fk    ! max MLE buoyancy flux 
     254      REAL(wp), DIMENSION(jpi,jpj) :: zdiff_mle ! extra MLE vertical diff 
     255      REAL(wp), DIMENSION(jpi,jpj) :: zvel_mle  ! velocity scale for dhdt with stable ML and FK 
     256 
    198257      REAL(wp), DIMENSION(jpi,jpj) :: zustke    ! Surface Stokes drift 
    199258      REAL(wp), DIMENSION(jpi,jpj) :: zla       ! Trubulent Langmuir number 
    … …  
    201260      REAL(wp), DIMENSION(jpi,jpj) :: zsin_wind ! Sin angle of surface stress 
    202261      REAL(wp), DIMENSION(jpi,jpj) :: zhol      ! Stability parameter for boundary layer 
    203       LOGICAL, DIMENSION(:,:), ALLOCATABLE :: lconv ! unstable/stable bl 
     262      LOGICAL, DIMENSION(jpi,jpj)  :: lconv     ! unstable/stable bl 
     263      LOGICAL, DIMENSION(jpi,jpj)  :: lshear    ! Shear layers 
     264      LOGICAL, DIMENSION(jpi,jpj)  :: lpyc      ! OSBL pycnocline present 
     265      LOGICAL, DIMENSION(jpi,jpj)  :: lflux     ! surface flux extends below OSBL into MLE layer. 
     266      LOGICAL, DIMENSION(jpi,jpj)  :: lmle      ! MLE layer increases in hickness. 
    204267 
    205268      ! mixed-layer variables 
    … …  
    207270      INTEGER, DIMENSION(jpi,jpj) :: ibld ! level of boundary layer base 
    208271      INTEGER, DIMENSION(jpi,jpj) :: imld ! level of mixed-layer depth (pycnocline top) 
     272      INTEGER, DIMENSION(jpi,jpj) :: jp_ext, jp_ext_mle ! offset for external level 
     273      INTEGER, DIMENSION(jpi, jpj) :: j_ddh ! Type of shear layer 
    209274 
    210275      REAL(wp) :: ztgrad,zsgrad,zbgrad ! Temporary variables used to calculate pycnocline gradients 
    … …  
    213278      REAL(wp), DIMENSION(jpi,jpj) :: zhbl  ! bl depth - grid 
    214279      REAL(wp), DIMENSION(jpi,jpj) :: zhml  ! ml depth - grid 
     280 
     281      REAL(wp), DIMENSION(jpi,jpj) :: zhmle ! MLE depth - grid 
     282      REAL(wp), DIMENSION(jpi,jpj) :: zmld  ! ML depth on grid 
     283 
    215284      REAL(wp), DIMENSION(jpi,jpj) :: zdh   ! pycnocline depth - grid 
    216285      REAL(wp), DIMENSION(jpi,jpj) :: zdhdt ! BL depth tendency 
    217       REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zrh_bl  ! averages over the depth of the blayer 
    218       REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zrh_ml  ! averages over the depth of the mixed layer 
    219       REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdrh_bl,zdb_bl ! difference between blayer average and parameter at base of blayer 
    220       REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdrh_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer 
    221       REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 
    222       REAL(wp), DIMENSION(jpi,jpj) :: zuw_bse,zvw_bse  ! momentum fluxes at the top of the pycnocline 
     286      REAL(wp), DIMENSION(jpi,jpj) :: zddhdt                                    ! correction to dhdt due to internal structure. 
     287      REAL(wp), DIMENSION(jpi,jpj) :: zdtdz_bl_ext,zdsdz_bl_ext,zdbdz_bl_ext              ! external temperature/salinity and buoyancy gradients 
     288      REAL(wp), DIMENSION(jpi,jpj) :: zdtdz_mle_ext,zdsdz_mle_ext,zdbdz_mle_ext              ! external temperature/salinity and buoyancy gradients 
     289      REAL(wp), DIMENSION(jpi,jpj) :: zdtdx, zdtdy, zdsdx, zdsdy      ! horizontal gradients for Fox-Kemper parametrization. 
     290 
     291      REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zb_bl  ! averages over the depth of the blayer 
     292      REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zb_ml  ! averages over the depth of the mixed layer 
     293      REAL(wp), DIMENSION(jpi,jpj) :: zt_mle,zs_mle,zu_mle,zv_mle,zb_mle  ! averages over the depth of the MLE layer 
     294      REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdb_bl ! difference between blayer average and parameter at base of blayer 
     295      REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer 
     296      REAL(wp), DIMENSION(jpi,jpj) :: zdt_mle,zds_mle,zdu_mle,zdv_mle,zdb_mle ! difference between MLE layer average and parameter at base of blayer 
     297!      REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 
     298      REAL(wp) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 
     299      REAL(wp) :: zuw_bse,zvw_bse  ! momentum fluxes at the top of the pycnocline 
    223300      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz_pyc    ! parametrized gradient of temperature in pycnocline 
    224301      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdsdz_pyc    ! parametrised gradient of salinity in pycnocline 
    … …  
    226303      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz_pyc    ! u-shear across the pycnocline 
    227304      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdvdz_pyc    ! v-shear across the pycnocline 
    228  
     305      REAL(wp), DIMENSION(jpi,jpj) :: zdbds_mle    ! Magnitude of horizontal buoyancy gradient. 
    229306      ! Flux-gradient relationship variables 
     307      REAL(wp), DIMENSION(jpi, jpj) :: zshear, zri_i ! Shear production and interfacial richardon number. 
    230308 
    231309      REAL(wp) :: zl_c,zl_l,zl_eps  ! Used to calculate turbulence length scale. 
    232310 
    233       REAL(wp), DIMENSION(jpi,jpj) :: zdifml_sc,zvisml_sc,zdifpyc_sc,zvispyc_sc,zbeta_d_sc,zbeta_v_sc ! Scales for eddy diffusivity/viscosity 
     311      REAL(wp) :: za_cubic, zb_cubic, zc_cubic, zd_cubic ! coefficients in cubic polynomial specifying diffusivity in pycnocline.   
    234312      REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_1,zsc_ws_1 ! Temporary scales used to calculate scalar non-gradient terms. 
     313      REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term/ 
    235314      REAL(wp), DIMENSION(jpi,jpj) :: zsc_uw_1,zsc_uw_2,zsc_vw_1,zsc_vw_2 ! Temporary scales for non-gradient momentum flux terms. 
    236315      REAL(wp), DIMENSION(jpi,jpj) :: zhbl_t ! holds boundary layer depth updated by full timestep 
    … …  
    243322      ! Temporary variables 
    244323      INTEGER :: inhml 
    245       INTEGER :: i_lconv_alloc 
    246324      REAL(wp) :: znd,znd_d,zznd_ml,zznd_pyc,zznd_d ! temporary non-dimensional depths used in various routines 
    247325      REAL(wp) :: ztemp, zari, zpert, zzdhdt, zdb   ! temporary variables 
    248326      REAL(wp) :: zthick, zz0, zz1 ! temporary variables 
    249327      REAL(wp) :: zvel_max, zhbl_s ! temporary variables 
    250       REAL(wp) :: zfac             ! temporary variable 
     328      REAL(wp) :: zfac, ztmp       ! temporary variable 
    251329      REAL(wp) :: zus_x, zus_y     ! temporary Stokes drift 
    252330      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zviscos ! viscosity 
    253331      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdiffut ! t-diffusivity 
     332      REAL(wp), DIMENSION(jpi,jpj) :: zalpha_pyc 
     333      REAL(wp), DIMENSION(jpi,jpj) :: ztau_sc_u ! dissipation timescale at baes of WML. 
     334      REAL(wp) :: zdelta_pyc, zwt_pyc_sc_1, zws_pyc_sc_1, zzeta_pyc 
     335      REAL(wp) :: zbuoy_pyc_sc, zomega, zvw_max 
     336      INTEGER :: ibld_ext=0                          ! does not have to be zero for modified scheme 
     337      REAL(wp) :: zgamma_b_nd, zgamma_b, zdhoh, ztau 
     338      REAL(wp) :: zzeta_s = 0._wp 
     339      REAL(wp) :: zzeta_v = 0.46 
     340      REAL(wp) :: zabsstke 
     341      REAL(wp) :: zsqrtpi, z_two_thirds, zproportion, ztransp, zthickness 
     342      REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zdstokes0, zf, zexperfc 
    254343 
    255344      ! For debugging 
    … …  
    257346      !!-------------------------------------------------------------------- 
    258347      ! 
    259       ALLOCATE( lconv(jpi,jpj),  STAT= i_lconv_alloc ) 
    260       IF( i_lconv_alloc /= 0 )   CALL ctl_warn('zdf_osm: failed to allocate lconv') 
    261  
    262348      ibld(:,:)   = 0     ; imld(:,:)  = 0 
    263349      zrad0(:,:)  = 0._wp ; zradh(:,:) = 0._wp ; zradav(:,:)    = 0._wp ; zustar(:,:)    = 0._wp 
    … …  
    267353      zustke(:,:) = 0._wp ; zla(:,:)   = 0._wp ; zcos_wind(:,:) = 0._wp ; zsin_wind(:,:) = 0._wp 
    268354      zhol(:,:)   = 0._wp 
    269       lconv(:,:)  = .FALSE. 
     355      lconv(:,:)  = .FALSE.; lpyc(:,:) = .FALSE. ; lflux(:,:) = .FALSE. ;  lmle(:,:) = .FALSE. 
    270356      ! mixed layer 
    271357      ! no initialization of zhbl or zhml (or zdh?) 
    272358      zhbl(:,:)    = 1._wp ; zhml(:,:)    = 1._wp ; zdh(:,:)      = 1._wp ; zdhdt(:,:)   = 0._wp 
    273       zt_bl(:,:)   = 0._wp ; zs_bl(:,:)   = 0._wp ; zu_bl(:,:)    = 0._wp ; zv_bl(:,:)   = 0._wp 
    274       zrh_bl(:,:)  = 0._wp ; zt_ml(:,:)   = 0._wp ; zs_ml(:,:)    = 0._wp ; zu_ml(:,:)   = 0._wp 
    275       zv_ml(:,:)   = 0._wp ; zrh_ml(:,:)  = 0._wp ; zdt_bl(:,:)   = 0._wp ; zds_bl(:,:)  = 0._wp 
    276       zdu_bl(:,:)  = 0._wp ; zdv_bl(:,:)  = 0._wp ; zdrh_bl(:,:)  = 0._wp ; zdb_bl(:,:)  = 0._wp 
     359      zt_bl(:,:)   = 0._wp ; zs_bl(:,:)   = 0._wp ; zu_bl(:,:)    = 0._wp 
     360      zv_bl(:,:)   = 0._wp ; zb_bl(:,:)  = 0._wp 
     361      zt_ml(:,:)   = 0._wp ; zs_ml(:,:)    = 0._wp ; zu_ml(:,:)   = 0._wp 
     362      zt_mle(:,:)   = 0._wp ; zs_mle(:,:)    = 0._wp ; zu_mle(:,:)   = 0._wp 
     363      zb_mle(:,:) = 0._wp 
     364      zv_ml(:,:)   = 0._wp ; zdt_bl(:,:)   = 0._wp ; zds_bl(:,:)  = 0._wp 
     365      zdu_bl(:,:)  = 0._wp ; zdv_bl(:,:)  = 0._wp ; zdb_bl(:,:)  = 0._wp 
    277366      zdt_ml(:,:)  = 0._wp ; zds_ml(:,:)  = 0._wp ; zdu_ml(:,:)   = 0._wp ; zdv_ml(:,:)  = 0._wp 
    278       zdrh_ml(:,:) = 0._wp ; zdb_ml(:,:)  = 0._wp ; zwth_ent(:,:) = 0._wp ; zws_ent(:,:) = 0._wp 
    279       zuw_bse(:,:) = 0._wp ; zvw_bse(:,:) = 0._wp 
     367      zdb_ml(:,:)  = 0._wp 
     368      zdt_mle(:,:)  = 0._wp ; zds_mle(:,:)  = 0._wp ; zdu_mle(:,:)   = 0._wp 
     369      zdv_mle(:,:)  = 0._wp ; zdb_mle(:,:)  = 0._wp 
     370      zwth_ent = 0._wp ; zws_ent = 0._wp 
    280371      ! 
    281372      zdtdz_pyc(:,:,:) = 0._wp ; zdsdz_pyc(:,:,:) = 0._wp ; zdbdz_pyc(:,:,:) = 0._wp 
    282373      zdudz_pyc(:,:,:) = 0._wp ; zdvdz_pyc(:,:,:) = 0._wp 
    283374      ! 
     375      zdtdz_bl_ext(:,:) = 0._wp ; zdsdz_bl_ext(:,:) = 0._wp ; zdbdz_bl_ext(:,:) = 0._wp 
     376 
     377      IF ( ln_osm_mle ) THEN  ! only initialise arrays if needed 
     378         zdtdx(:,:) = 0._wp ; zdtdy(:,:) = 0._wp ; zdsdx(:,:) = 0._wp 
     379         zdsdy(:,:) = 0._wp ; dbdx_mle(:,:) = 0._wp ; dbdy_mle(:,:) = 0._wp 
     380         zwb_fk(:,:) = 0._wp ; zvel_mle(:,:) = 0._wp; zdiff_mle(:,:) = 0._wp 
     381         zhmle(:,:) = 0._wp  ; zmld(:,:) = 0._wp 
     382      ENDIF 
     383      zwb_fk_b(:,:) = 0._wp   ! must be initialised even with ln_osm_mle=F as used in zdf_osm_calculate_dhdt 
     384 
    284385      ! Flux-Gradient arrays. 
    285       zdifml_sc(:,:)  = 0._wp ; zvisml_sc(:,:)  = 0._wp ; zdifpyc_sc(:,:) = 0._wp 
    286       zvispyc_sc(:,:) = 0._wp ; zbeta_d_sc(:,:) = 0._wp ; zbeta_v_sc(:,:) = 0._wp 
    287386      zsc_wth_1(:,:)  = 0._wp ; zsc_ws_1(:,:)   = 0._wp ; zsc_uw_1(:,:)   = 0._wp 
    288387      zsc_uw_2(:,:)   = 0._wp ; zsc_vw_1(:,:)   = 0._wp ; zsc_vw_2(:,:)   = 0._wp 
    … …  
    292391      ghams(:,:,:)   = 0._wp ; ghamu(:,:,:)   = 0._wp ; ghamv(:,:,:) = 0._wp 
    293392 
     393      zddhdt(:,:) = 0._wp 
    294394      ! hbl = MAX(hbl,epsln) 
    295395      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    326426        zwbav(ji,jj) = grav  * zthermal * zwthav(ji,jj) - grav  * zbeta * zwsav(ji,jj) 
    327427        ! Surface upward velocity fluxes 
    328         zuw0(ji,jj) = -utau(ji,jj) * r1_rho0 * tmask(ji,jj,1) 
    329         zvw0(ji,jj) = -vtau(ji,jj) * r1_rho0 * tmask(ji,jj,1) 
     428        zuw0(ji,jj) = - 0.5 * (utau(ji-1,jj) + utau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) 
     429        zvw0(ji,jj) = - 0.5 * (vtau(ji,jj-1) + vtau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) 
    330430        ! Friction velocity (zustar), at T-point : LMD94 eq. 2 
    331431        zustar(ji,jj) = MAX( SQRT( SQRT( zuw0(ji,jj) * zuw0(ji,jj) + zvw0(ji,jj) * zvw0(ji,jj) ) ), 1.0e-8 ) 
    … …  
    340440           zus_x = zcos_wind(ji,jj) * zustar(ji,jj) / 0.3**2 
    341441           zus_y = zsin_wind(ji,jj) * zustar(ji,jj) / 0.3**2 
     442           ! Linearly 
    342443           zustke(ji,jj) = MAX ( SQRT( zus_x*zus_x + zus_y*zus_y), 1.0e-8 ) 
    343            ! dstokes(ji,jj) set to constant value rn_osm_dstokes from namelist in zdf_osm_init 
     444           dstokes(ji,jj) = rn_osm_dstokes 
    344445        END_2D 
    345446     ! Assume Pierson-Moskovitz wind-wave spectrum 
    … …  
    347448        DO_2D( 0, 0, 0, 0 ) 
    348449           ! Use wind speed wndm included in sbc_oce module 
    349            zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) 
    350            dstokes(ji,jj) = 0.12 * wndm(ji,jj)**2 / grav 
     450           zustke(ji,jj) =  MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) 
     451           dstokes(ji,jj) = MAX ( 0.12 * wndm(ji,jj)**2 / grav, 5.e-1) 
    351452        END_2D 
    352453     ! Use ECMWF wave fields as output from SBCWAVE 
    353454     CASE(2) 
    354455        zfac =  2.0_wp * rpi / 16.0_wp 
     456 
    355457        DO_2D( 0, 0, 0, 0 ) 
    356            ! The Langmur number from the ECMWF model appears to give La<0.3 for wind-driven seas. 
    357            !    The coefficient 0.8 gives La=0.3  in this situation. 
    358            ! It could represent the effects of the spread of wave directions 
    359            ! around the mean wind. The effect of this adjustment needs to be tested. 
    360            zustke(ji,jj) = MAX ( 1.0 * ( zcos_wind(ji,jj) * ut0sd(ji,jj ) + zsin_wind(ji,jj)  * vt0sd(ji,jj) ), & 
    361                 &                zustar(ji,jj) / ( 0.45 * 0.45 )                                                  ) 
    362            dstokes(ji,jj) = MAX(zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zustke(ji,jj)*wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) !rn_osm_dstokes ! 
     458           IF (hsw(ji,jj) > 1.e-4) THEN 
     459              ! Use  wave fields 
     460              zabsstke = SQRT(ut0sd(ji,jj)**2 + vt0sd(ji,jj)**2) 
     461              zustke(ji,jj) = MAX ( ( zcos_wind(ji,jj) * ut0sd(ji,jj) + zsin_wind(ji,jj)  * vt0sd(ji,jj) ), 1.0e-8) 
     462              dstokes(ji,jj) = MAX (zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zabsstke * wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) 
     463           ELSE 
     464              ! Assume masking issue (e.g. ice in ECMWF reanalysis but not in model run) 
     465              ! .. so default to Pierson-Moskowitz 
     466              zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) 
     467              dstokes(ji,jj) = MAX ( 0.12 * wndm(ji,jj)**2 / grav, 5.e-1) 
     468           END IF 
     469        END_2D 
     470     END SELECT 
     471 
     472     IF (ln_zdfosm_ice_shelter) THEN 
     473        ! Reduce both Stokes drift and its depth scale by ocean fraction to represent sheltering by ice 
     474        DO_2D( 0, 0, 0, 0 ) 
     475           zustke(ji,jj) = zustke(ji,jj) * (1.0_wp - fr_i(ji,jj)) 
     476           dstokes(ji,jj) = dstokes(ji,jj) * (1.0_wp - fr_i(ji,jj)) 
     477        END_2D 
     478     END IF 
     479 
     480     SELECT CASE (nn_osm_SD_reduce) 
     481     ! Reduce surface Stokes drift by a constant factor or following Breivik (2016) + van  Roekel (2012) or Grant (2020). 
     482     CASE(0) 
     483        ! The Langmur number from the ECMWF model (or from PM)  appears to give La<0.3 for wind-driven seas. 
     484        !    The coefficient rn_zdfosm_adjust_sd = 0.8 gives La=0.3  in this situation. 
     485        ! It could represent the effects of the spread of wave directions 
     486        ! around the mean wind. The effect of this adjustment needs to be tested. 
     487        IF(nn_osm_wave > 0) THEN 
     488           zustke(2:jpim1,2:jpjm1) = rn_zdfosm_adjust_sd * zustke(2:jpim1,2:jpjm1) 
     489        END IF 
     490     CASE(1) 
     491        ! van  Roekel (2012): consider average SD over top 10% of boundary layer 
     492        ! assumes approximate depth profile of SD from Breivik (2016) 
     493        zsqrtpi = SQRT(rpi) 
     494        z_two_thirds = 2.0_wp / 3.0_wp 
     495 
     496        DO_2D( 0, 0, 0, 0 ) 
     497           zthickness = rn_osm_hblfrac*hbl(ji,jj) 
     498           z2k_times_thickness =  zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 0.0000001_wp ) 
     499           zsqrt_depth = SQRT(z2k_times_thickness) 
     500           zexp_depth  = EXP(-z2k_times_thickness) 
     501           zustke(ji,jj) = zustke(ji,jj) * (1.0_wp - zexp_depth  & 
     502                &              - z_two_thirds * ( zsqrtpi*zsqrt_depth*z2k_times_thickness * ERFC(zsqrt_depth) & 
     503                &              + 1.0_wp - (1.0_wp + z2k_times_thickness)*zexp_depth ) ) / z2k_times_thickness 
     504 
     505        END_2D 
     506     CASE(2) 
     507        ! Grant (2020): Match to exponential with same SD and d/dz(Sd) at depth 10% of boundary layer 
     508        ! assumes approximate depth profile of SD from Breivik (2016) 
     509        zsqrtpi = SQRT(rpi) 
     510 
     511        DO_2D( 0, 0, 0, 0 ) 
     512           zthickness = rn_osm_hblfrac*hbl(ji,jj) 
     513           z2k_times_thickness =  zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 0.0000001_wp ) 
     514 
     515           IF(z2k_times_thickness < 50._wp) THEN 
     516              zsqrt_depth = SQRT(z2k_times_thickness) 
     517              zexperfc = zsqrtpi * zsqrt_depth * ERFC(zsqrt_depth) * EXP(z2k_times_thickness) 
     518           ELSE 
     519              ! asymptotic expansion of sqrt(pi)*zsqrt_depth*EXP(z2k_times_thickness)*ERFC(zsqrt_depth) for large z2k_times_thickness 
     520              ! See Abramowitz and Stegun, Eq. 7.1.23 
     521              ! zexperfc = 1._wp - (1/2)/(z2k_times_thickness)  + (3/4)/(z2k_times_thickness**2) - (15/8)/(z2k_times_thickness**3) 
     522              zexperfc = ((- 1.875_wp/z2k_times_thickness + 0.75_wp)/z2k_times_thickness - 0.5_wp)/z2k_times_thickness + 1.0_wp 
     523           END IF 
     524           zf = z2k_times_thickness*(1.0_wp/zexperfc - 1.0_wp) 
     525           dstokes(ji,jj) = 5.97 * zf * dstokes(ji,jj) 
     526           zustke(ji,jj) = zustke(ji,jj) * EXP(z2k_times_thickness * ( 1.0_wp / (2. * zf) - 1.0_wp )) * ( 1.0_wp - zexperfc) 
    363527        END_2D 
    364528     END SELECT 
    … …  
    369533        ! Langmuir velocity scale (zwstrl), at T-point 
    370534        zwstrl(ji,jj) = ( zustar(ji,jj) * zustar(ji,jj) * zustke(ji,jj) )**pthird 
    371         ! Modify zwstrl to allow for small and large values of dstokes/hbl. 
    372         ! Intended as a possible test. Doesn't affect LES results for entrainment, 
    373         !  but hasn't been shown to be correct as dstokes/h becomes large or small. 
    374         zwstrl(ji,jj) = zwstrl(ji,jj) *  & 
    375              & (1.12 * ( 1.0 - ( 1.0 - EXP( -hbl(ji,jj) / dstokes(ji,jj) ) ) * dstokes(ji,jj) / hbl(ji,jj) ))**pthird * & 
    376              & ( 1.0 - EXP( -15.0 * dstokes(ji,jj) / hbl(ji,jj) )) 
    377         ! define La this way so effects of Stokes penetration depth on velocity scale are included 
    378         zla(ji,jj) = SQRT ( zustar(ji,jj) / zwstrl(ji,jj) )**3 
     535        zla(ji,jj) = MAX(MIN(SQRT ( zustar(ji,jj) / ( zwstrl(ji,jj) + epsln ) )**3, 4.0), 0.2) 
     536        IF(zla(ji,jj) > 0.45) dstokes(ji,jj) = MIN(dstokes(ji,jj), 0.5_wp*hbl(ji,jj)) 
    379537        ! Velocity scale that tends to zustar for large Langmuir numbers 
    380538        zvstr(ji,jj) = ( zwstrl(ji,jj)**3  + & 
    … …  
    383541        ! limit maximum value of Langmuir number as approximate treatment for shear turbulence. 
    384542        ! Note zustke and zwstrl are not amended. 
    385         IF ( zla(ji,jj) >= 0.45 ) zla(ji,jj) = 0.45 
    386543        ! 
    387544        ! get convective velocity (zwstrc), stabilty scale (zhol) and logical conection flag lconv 
    … …  
    389546           zwstrc(ji,jj) = ( 2.0 * zwbav(ji,jj) * 0.9 * hbl(ji,jj) )**pthird 
    390547           zhol(ji,jj) = -0.9 * hbl(ji,jj) * 2.0 * zwbav(ji,jj) / (zvstr(ji,jj)**3 + epsln ) 
    391            lconv(ji,jj) = .TRUE. 
    392         ELSE 
     548         ELSE 
    393549           zhol(ji,jj) = -hbl(ji,jj) *  2.0 * zwbav(ji,jj)/ (zvstr(ji,jj)**3  + epsln ) 
    394            lconv(ji,jj) = .FALSE. 
    395550        ENDIF 
    396551     END_2D 
    … …  
    399554     ! Mixed-layer model - calculate averages over the boundary layer, and the change in the boundary layer depth 
    400555     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    401      ! BL must be always 2 levels deep. 
    402       hbl(:,:) = MAX(hbl(:,:), gdepw(:,:,3,Kmm) ) 
    403       ibld(:,:) = 3 
    404       DO_3D( 0, 0, 0, 0, 4, jpkm1 ) 
     556     ! BL must be always 4 levels deep. 
     557     ! For calculation of lateral buoyancy gradients for FK in 
     558     ! zdf_osm_zmld_horizontal_gradients need halo values for ibld, so must 
     559     ! previously exist for hbl also. 
     560 
     561     ! agn 23/6/20: not clear all this is needed, as hbl checked after it is re-calculated anyway 
     562     ! ########################################################################## 
     563      hbl(:,:) = MAX(hbl(:,:), gdepw(:,:,4,Kmm) ) 
     564      ibld(:,:) = 4 
     565      DO_3D( 1, 1, 1, 1, 5, jpkm1 ) 
    405566         IF ( hbl(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN 
    406567            ibld(ji,jj) = MIN(mbkt(ji,jj), jk) 
    407568         ENDIF 
    408569      END_3D 
     570     ! ########################################################################## 
    409571 
    410572      DO_2D( 0, 0, 0, 0 ) 
    411             zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 
    412             zbeta    = rab_n(ji,jj,1,jp_sal) 
    413             zt   = 0._wp 
    414             zs   = 0._wp 
    415             zu   = 0._wp 
    416             zv   = 0._wp 
    417             ! average over depth of boundary layer 
    418             zthick=0._wp 
    419             DO jm = 2, ibld(ji,jj) 
    420                zthick=zthick+e3t(ji,jj,jm,Kmm) 
    421                zt   = zt  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 
    422                zs   = zs  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 
    423                zu   = zu  + e3t(ji,jj,jm,Kmm) & 
    424                   &            * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 
    425                   &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 
    426                zv   = zv  + e3t(ji,jj,jm,Kmm) & 
    427                   &            * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 
    428                   &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 
    429             END DO 
    430             zt_bl(ji,jj) = zt / zthick 
    431             zs_bl(ji,jj) = zs / zthick 
    432             zu_bl(ji,jj) = zu / zthick 
    433             zv_bl(ji,jj) = zv / zthick 
    434             zdt_bl(ji,jj) = zt_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 
    435             zds_bl(ji,jj) = zs_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 
    436             zdu_bl(ji,jj) = zu_bl(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 
    437                   &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 
    438             zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 
    439                   &   / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 
    440             zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) 
    441             IF ( lconv(ji,jj) ) THEN    ! Convective 
    442                    zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & 
    443                         &            + 0.135 * zla(ji,jj) * zwstrl(ji,jj)**3/hbl(ji,jj) ) 
    444  
    445                    zvel_max =  - ( 1.0 + 1.0 * ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) & 
    446                         &   * zwb_ent(ji,jj) / ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
    447 ! Entrainment including component due to shear turbulence. Modified Langmuir component, but gives same result for La=0.3 For testing uncomment. 
    448 !                      zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & 
    449 !                           &            + ( 0.15 * ( 1.0 - EXP( -0.5 * zla(ji,jj) ) ) + 0.03 / zla(ji,jj)**2 ) * zustar(ji,jj)**3/hbl(ji,jj) ) 
    450  
    451 !                      zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / zhbl(ji,jj) ) * zwb_ent(ji,jj) / & 
    452 !                           &       ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
    453                    zzdhdt = - zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj),0.0) ) 
    454             ELSE                        ! Stable 
    455                    zzdhdt = 0.32 * ( hbli(ji,jj) / hbl(ji,jj) -1.0 ) * zwstrl(ji,jj)**3 / hbli(ji,jj) & 
    456                         &   + ( ( 0.32 / 3.0 ) * exp ( -2.5 * ( hbli(ji,jj) / hbl(ji,jj) - 1.0 ) ) & 
    457                         & - ( 0.32 / 3.0 - 0.135 * zla(ji,jj) ) * exp ( -12.5 * ( hbli(ji,jj) / hbl(ji,jj) ) ) ) & 
    458                         &  * zwstrl(ji,jj)**3 / hbli(ji,jj) 
    459                    zzdhdt = zzdhdt + zwbav(ji,jj) 
    460                    IF ( zzdhdt < 0._wp ) THEN 
    461                    ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 
    462                       zpert   = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_Dt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) 
    463                    ELSE 
    464                       zpert   = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_Dt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) & 
    465                            &  + MAX( zdb_bl(ji,jj), 0.0 ) 
    466                    ENDIF 
    467                    zzdhdt = 2.0 * zzdhdt / zpert 
    468             ENDIF 
    469             zdhdt(ji,jj) = zzdhdt 
     573         zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 
     574         imld(ji,jj) = MAX(3,ibld(ji,jj) - MAX( INT( dh(ji,jj) / e3t(ji, jj, ibld(ji,jj), Kmm )) , 1 )) 
     575         zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
     576         zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
    470577      END_2D 
    471  
    472       ! Calculate averages over depth of boundary layer 
    473       imld = ibld           ! use imld to hold previous blayer index 
    474       ibld(:,:) = 3 
    475  
    476       zhbl_t(:,:) = hbl(:,:) + (zdhdt(:,:) - ww(ji,jj,ibld(ji,jj)))* rn_Dt ! certainly need wb here, so subtract it 
    477       zhbl_t(:,:) = MIN(zhbl_t(:,:), ht(:,:)) 
    478       zdhdt(:,:) = MIN(zdhdt(:,:), (zhbl_t(:,:) - hbl(:,:))/rn_Dt + ww(ji,jj,ibld(ji,jj))) ! adjustment to represent limiting by ocean bottom 
     578      ! Averages over well-mixed and boundary layer 
     579      jp_ext(:,:) = 2 
     580      CALL zdf_osm_vertical_average(ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl) 
     581!      jp_ext(:,:) = ibld(:,:) - imld(:,:) + 1 
     582      CALL zdf_osm_vertical_average(ibld, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml) 
     583! Velocity components in frame aligned with surface stress. 
     584      CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_ml, zv_ml, zdu_ml, zdv_ml ) 
     585      CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_bl, zv_bl, zdu_bl, zdv_bl ) 
     586! Determine the state of the OSBL, stable/unstable, shear/no shear 
     587      CALL zdf_osm_osbl_state( lconv, lshear, j_ddh, zwb_ent, zwb_min, zshear, zri_i ) 
     588 
     589      IF ( ln_osm_mle ) THEN 
     590! Fox-Kemper Scheme 
     591         mld_prof = 4 
     592         DO_3D( 0, 0, 0, 0, 5, jpkm1 ) 
     593         IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN(mbkt(ji,jj), jk) 
     594         END_3D 
     595         jp_ext_mle(:,:) = 2 
     596        CALL zdf_osm_vertical_average(mld_prof, jp_ext_mle, zt_mle, zs_mle, zb_mle, zu_mle, zv_mle, zdt_mle, zds_mle, zdb_mle, zdu_mle, zdv_mle) 
     597 
     598         DO_2D( 0, 0, 0, 0 ) 
     599           zhmle(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) 
     600         END_2D 
     601 
     602!! External gradient 
     603         CALL zdf_osm_external_gradients( ibld+2, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) 
     604         CALL zdf_osm_zmld_horizontal_gradients( zmld, zdtdx, zdtdy, zdsdx, zdsdy, dbdx_mle, dbdy_mle, zdbds_mle ) 
     605         CALL zdf_osm_external_gradients( mld_prof, zdtdz_mle_ext, zdsdz_mle_ext, zdbdz_mle_ext ) 
     606         CALL zdf_osm_osbl_state_fk( lpyc, lflux, lmle, zwb_fk ) 
     607         CALL zdf_osm_mle_parameters( mld_prof, hmle, zhmle, zvel_mle, zdiff_mle ) 
     608      ELSE    ! ln_osm_mle 
     609! FK not selected, Boundary Layer only. 
     610         lpyc(:,:) = .TRUE. 
     611         lflux(:,:) = .FALSE. 
     612         lmle(:,:) = .FALSE. 
     613         DO_2D( 0, 0, 0, 0 ) 
     614          IF ( lconv(ji,jj) .AND. zdb_bl(ji,jj) < rn_osm_bl_thresh ) lpyc(ji,jj) = .FALSE. 
     615         END_2D 
     616      ENDIF   ! ln_osm_mle 
     617 
     618! Test if pycnocline well resolved 
     619      DO_2D( 0, 0, 0, 0 ) 
     620       IF (lconv(ji,jj) ) THEN 
     621          ztmp = 0.2 * zhbl(ji,jj) / e3w(ji,jj,ibld(ji,jj),Kmm) 
     622          IF ( ztmp > 6 ) THEN 
     623   ! pycnocline well resolved 
     624            jp_ext(ji,jj) = 1 
     625          ELSE 
     626   ! pycnocline poorly resolved 
     627            jp_ext(ji,jj) = 0 
     628          ENDIF 
     629       ELSE 
     630   ! Stable conditions 
     631         jp_ext(ji,jj) = 0 
     632       ENDIF 
     633      END_2D 
     634 
     635      CALL zdf_osm_vertical_average(ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl ) 
     636!      jp_ext = ibld-imld+1 
     637      CALL zdf_osm_vertical_average(imld-1, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml) 
     638! Rate of change of hbl 
     639      CALL zdf_osm_calculate_dhdt( zdhdt, zddhdt ) 
     640      DO_2D( 0, 0, 0, 0 ) 
     641       zhbl_t(ji,jj) = hbl(ji,jj) + (zdhdt(ji,jj) - ww(ji,jj,ibld(ji,jj)))* rn_Dt ! certainly need ww here, so subtract it 
     642            ! adjustment to represent limiting by ocean bottom 
     643       IF ( zhbl_t(ji,jj) >= gdepw(ji, jj, mbkt(ji,jj) + 1, Kmm ) ) THEN 
     644          zhbl_t(ji,jj) = MIN(zhbl_t(ji,jj), gdepw(ji,jj, mbkt(ji,jj) + 1, Kmm) - depth_tol)! ht(:,:)) 
     645          lpyc(ji,jj) = .FALSE. 
     646       ENDIF 
     647      END_2D 
     648 
     649      imld(:,:) = ibld(:,:)           ! use imld to hold previous blayer index 
     650      ibld(:,:) = 4 
    479651 
    480652      DO_3D( 0, 0, 0, 0, 4, jpkm1 ) 
    481653         IF ( zhbl_t(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN 
    482             ibld(ji,jj) =  MIN(mbkt(ji,jj), jk) 
     654            ibld(ji,jj) = jk 
    483655         ENDIF 
    484656      END_3D 
    … …  
    487659! Step through model levels taking account of buoyancy change to determine the effect on dhdt 
    488660! 
     661      CALL zdf_osm_timestep_hbl( zdhdt ) 
     662! is external level in bounds? 
     663 
     664      CALL zdf_osm_vertical_average( ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl ) 
     665! 
     666! 
     667! Check to see if lpyc needs to be changed  
     668 
     669      CALL zdf_osm_pycnocline_thickness( dh, zdh ) 
     670 
    489671      DO_2D( 0, 0, 0, 0 ) 
    490          IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN 
     672       IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh .or. ibld(ji,jj) + jp_ext(ji,jj) >= mbkt(ji,jj) .or. ibld(ji,jj)-imld(ji,jj) == 1 ) lpyc(ji,jj) = .FALSE.  
     673      END_2D 
     674 
     675      dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. )  !  Limit delta for shallow boundary layers for calculating flux-gradient terms. 
    491676! 
    492 ! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. 
    493 ! 
    494             zhbl_s = hbl(ji,jj) 
    495             jm = imld(ji,jj) 
    496             zthermal = rab_n(ji,jj,1,jp_tem) 
    497             zbeta = rab_n(ji,jj,1,jp_sal) 
    498             IF ( lconv(ji,jj) ) THEN 
    499 !unstable 
    500                zvel_max =  - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) & 
    501                     &   * zwb_ent(ji,jj) / ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
    502  
    503                DO jk = imld(ji,jj), ibld(ji,jj) 
    504                   zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) & 
    505                        & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) + zvel_max 
    506  
    507                   zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ),   & 
    508                      &                     e3w(ji,jj,jk,Kmm) ) 
    509                   zhbl_s = MIN(zhbl_s, ht(ji,jj)) 
    510  
    511                   IF ( zhbl_s >= gdepw(ji,jj,jm+1,Kmm) ) jm = jm + 1 
    512                END DO 
    513                hbl(ji,jj) = zhbl_s 
    514                ibld(ji,jj) = jm 
    515                hbli(ji,jj) = hbl(ji,jj) 
    516             ELSE 
    517 ! stable 
    518                DO jk = imld(ji,jj), ibld(ji,jj) 
    519                   zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) )          & 
    520                        &               - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) & 
    521                        & + 2.0 * zwstrl(ji,jj)**2 / zhbl_s 
    522  
    523                   zhbl_s = zhbl_s +  (                                                                                & 
    524                        &                     0.32         *                         ( hbli(ji,jj) / zhbl_s -1.0 )     & 
    525                        &               * zwstrl(ji,jj)**3 / hbli(ji,jj)                                               & 
    526                        &               + ( ( 0.32 / 3.0 )           * EXP( -  2.5 * ( hbli(ji,jj) / zhbl_s -1.0 ) )   & 
    527                        &               -   ( 0.32 / 3.0  - 0.0485 ) * EXP( - 12.5 * ( hbli(ji,jj) / zhbl_s      ) ) ) & 
    528                        &          * zwstrl(ji,jj)**3 / hbli(ji,jj) ) / zdb * e3w(ji,jj,jk,Kmm) / zdhdt(ji,jj)  ! ALMG to investigate whether need to include ww here 
    529  
    530                   zhbl_s = MIN(zhbl_s, ht(ji,jj)) 
    531                   IF ( zhbl_s >= gdepw(ji,jj,jm,Kmm) ) jm = jm + 1 
    532                END DO 
    533                hbl(ji,jj) = MAX(zhbl_s, gdepw(ji,jj,3,Kmm) ) 
    534                ibld(ji,jj) = MAX(jm, 3 ) 
    535                IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) 
    536             ENDIF   ! IF ( lconv ) 
    537          ELSE 
    538 ! change zero or one model level. 
    539             hbl(ji,jj) = zhbl_t(ji,jj) 
    540             IF ( lconv(ji,jj) ) THEN 
    541                hbli(ji,jj) = hbl(ji,jj) 
    542             ELSE 
    543                hbl(ji,jj) = MAX(hbl(ji,jj), gdepw(ji,jj,3,Kmm) ) 
    544                IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) 
    545             ENDIF 
    546          ENDIF 
    547          zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 
    548       END_2D 
    549       dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. )  !  Limit delta for shallow boundary layers for calculating flux-gradient terms. 
    550  
    551 ! Recalculate averages over boundary layer after depth updated 
    552      ! Consider later  combining this into the loop above and looking for columns 
    553      ! where the index for base of the boundary layer have changed 
    554       DO_2D( 0, 0, 0, 0 ) 
    555             zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 
    556             zbeta    = rab_n(ji,jj,1,jp_sal) 
    557             zt   = 0._wp 
    558             zs   = 0._wp 
    559             zu   = 0._wp 
    560             zv   = 0._wp 
    561             ! average over depth of boundary layer 
    562             zthick=0._wp 
    563             DO jm = 2, ibld(ji,jj) 
    564                zthick=zthick+e3t(ji,jj,jm,Kmm) 
    565                zt   = zt  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 
    566                zs   = zs  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 
    567                zu   = zu  + e3t(ji,jj,jm,Kmm) & 
    568                   &            * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 
    569                   &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 
    570                zv   = zv  + e3t(ji,jj,jm,Kmm) & 
    571                   &            * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 
    572                   &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 
    573             END DO 
    574             zt_bl(ji,jj) = zt / zthick 
    575             zs_bl(ji,jj) = zs / zthick 
    576             zu_bl(ji,jj) = zu / zthick 
    577             zv_bl(ji,jj) = zv / zthick 
    578             zdt_bl(ji,jj) = zt_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 
    579             zds_bl(ji,jj) = zs_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 
    580             zdu_bl(ji,jj) = zu_bl(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 
    581                    &   / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 
    582             zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 
    583                    &  / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 
    584             zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) 
    585             zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 
    586             IF ( lconv(ji,jj) ) THEN 
    587                IF ( zdb_bl(ji,jj) > 0._wp )THEN 
    588                   IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN  ! near neutral stability 
    589                         zari = 4.5 * ( zvstr(ji,jj)**2 ) & 
    590                           & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 
    591                   ELSE                                                     ! unstable 
    592                         zari = 4.5 * ( zwstrc(ji,jj)**2 ) & 
    593                           & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 
    594                   ENDIF 
    595                   IF ( zari > 0.2 ) THEN                                                ! This test checks for weakly stratified pycnocline 
    596                      zari = 0.2 
    597                      zwb_ent(ji,jj) = 0._wp 
    598                   ENDIF 
    599                   inhml = MAX( INT( zari * zhbl(ji,jj)   & 
    600                      &              / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 
    601                   imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 
    602                   zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
    603                   zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
    604                ELSE  ! IF (zdb_bl) 
    605                   imld(ji,jj) = ibld(ji,jj) - 1 
    606                   zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
    607                   zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
    608                ENDIF 
    609             ELSE   ! IF (lconv) 
    610                IF ( zdhdt(ji,jj) >= 0.0 ) THEN    ! probably shouldn't include wm here 
    611                ! boundary layer deepening 
    612                   IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
    613                ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 
    614                      zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 
    615                        & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01  , 0.2 ) 
    616                      inhml = MAX( INT( zari * zhbl(ji,jj)   & 
    617                         &             / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 
    618                      imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 
    619                      zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
    620                      zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
    621                   ELSE 
    622                      imld(ji,jj) = ibld(ji,jj) - 1 
    623                      zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
    624                      zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
    625                   ENDIF ! IF (zdb_bl > 0.0) 
    626                ELSE     ! IF(dhdt >= 0) 
    627                ! boundary layer collapsing. 
    628                   imld(ji,jj) = ibld(ji,jj) 
    629                   zhml(ji,jj) = zhbl(ji,jj) 
    630                   zdh(ji,jj) = 0._wp 
    631                ENDIF    ! IF (dhdt >= 0) 
    632             ENDIF       ! IF (lconv) 
    633       END_2D 
    634  
    635       ! Average over the depth of the mixed layer in the convective boundary layer 
    636       ! Also calculate entrainment fluxes for temperature and salinity 
    637       DO_2D( 0, 0, 0, 0 ) 
    638          zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 
    639          zbeta    = rab_n(ji,jj,1,jp_sal) 
    640          IF ( lconv(ji,jj) ) THEN 
    641             zt   = 0._wp 
    642             zs   = 0._wp 
    643             zu   = 0._wp 
    644             zv   = 0._wp 
    645             ! average over depth of boundary layer 
    646             zthick=0._wp 
    647             DO jm = 2, imld(ji,jj) 
    648                zthick=zthick+e3t(ji,jj,jm,Kmm) 
    649                zt   = zt  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 
    650                zs   = zs  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 
    651                zu   = zu  + e3t(ji,jj,jm,Kmm) & 
    652                   &            * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 
    653                   &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 
    654                zv   = zv  + e3t(ji,jj,jm,Kmm) & 
    655                   &            * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 
    656                   &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 
    657             END DO 
    658             zt_ml(ji,jj) = zt / zthick 
    659             zs_ml(ji,jj) = zs / zthick 
    660             zu_ml(ji,jj) = zu / zthick 
    661             zv_ml(ji,jj) = zv / zthick 
    662             zdt_ml(ji,jj) = zt_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 
    663             zds_ml(ji,jj) = zs_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 
    664             zdu_ml(ji,jj) = zu_ml(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 
    665                   &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 
    666             zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 
    667                   &    / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 
    668             zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) 
    669          ELSE 
    670          ! stable, if entraining calulate average below interface layer. 
    671             IF ( zdhdt(ji,jj) >= 0._wp ) THEN 
    672                zt   = 0._wp 
    673                zs   = 0._wp 
    674                zu   = 0._wp 
    675                zv   = 0._wp 
    676                ! average over depth of boundary layer 
    677                zthick=0._wp 
    678                DO jm = 2, imld(ji,jj) 
    679                   zthick=zthick+e3t(ji,jj,jm,Kmm) 
    680                   zt   = zt  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 
    681                   zs   = zs  + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 
    682                   zu   = zu  + e3t(ji,jj,jm,Kmm) & 
    683                      &            * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 
    684                      &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 
    685                   zv   = zv  + e3t(ji,jj,jm,Kmm) & 
    686                      &            * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 
    687                      &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 
    688                END DO 
    689                zt_ml(ji,jj) = zt / zthick 
    690                zs_ml(ji,jj) = zs / zthick 
    691                zu_ml(ji,jj) = zu / zthick 
    692                zv_ml(ji,jj) = zv / zthick 
    693                zdt_ml(ji,jj) = zt_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 
    694                zds_ml(ji,jj) = zs_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 
    695                zdu_ml(ji,jj) = zu_ml(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 
    696                      &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 
    697                zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 
    698                      &    / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 
    699                zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) 
    700             ENDIF 
    701          ENDIF 
    702       END_2D 
    703     ! 
     677    ! Average over the depth of the mixed layer in the convective boundary layer 
     678!      jp_ext = ibld - imld +1 
     679      CALL zdf_osm_vertical_average( imld-1, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml ) 
    704680    ! rotate mean currents and changes onto wind align co-ordinates 
    705681    ! 
    706  
    707       DO_2D( 0, 0, 0, 0 ) 
    708          ztemp = zu_ml(ji,jj) 
    709          zu_ml(ji,jj) = zu_ml(ji,jj) * zcos_wind(ji,jj) + zv_ml(ji,jj) * zsin_wind(ji,jj) 
    710          zv_ml(ji,jj) = zv_ml(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 
    711          ztemp = zdu_ml(ji,jj) 
    712          zdu_ml(ji,jj) = zdu_ml(ji,jj) * zcos_wind(ji,jj) + zdv_ml(ji,jj) * zsin_wind(ji,jj) 
    713          zdv_ml(ji,jj) = zdv_ml(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 
    714  ! 
    715          ztemp = zu_bl(ji,jj) 
    716          zu_bl = zu_bl(ji,jj) * zcos_wind(ji,jj) + zv_bl(ji,jj) * zsin_wind(ji,jj) 
    717          zv_bl(ji,jj) = zv_bl(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 
    718          ztemp = zdu_bl(ji,jj) 
    719          zdu_bl(ji,jj) = zdu_bl(ji,jj) * zcos_wind(ji,jj) + zdv_bl(ji,jj) * zsin_wind(ji,jj) 
    720          zdv_bl(ji,jj) = zdv_bl(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 
    721       END_2D 
    722  
    723      zuw_bse = 0._wp 
    724      zvw_bse = 0._wp 
    725      DO_2D( 0, 0, 0, 0 ) 
    726  
    727         IF ( lconv(ji,jj) ) THEN 
    728            IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
    729               zwth_ent(ji,jj) = zwb_ent(ji,jj) * zdt_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) 
    730               zws_ent(ji,jj) = zwb_ent(ji,jj) * zds_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) 
    731            ENDIF 
    732         ELSE 
    733            zwth_ent(ji,jj) = -2.0 * zwthav(ji,jj) * ( (1.0 - 0.8) - ( 1.0 - 0.8)**(3.0/2.0) ) 
    734            zws_ent(ji,jj) = -2.0 * zwsav(ji,jj) * ( (1.0 - 0.8 ) - ( 1.0 - 0.8 )**(3.0/2.0) ) 
    735         ENDIF 
    736      END_2D 
    737  
     682     CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_ml, zv_ml, zdu_ml, zdv_ml ) 
     683     CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_bl, zv_bl, zdu_bl, zdv_bl ) 
    738684      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    739685      !  Pycnocline gradients for scalars and velocity 
    740686      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    741687 
    742        DO_2D( 0, 0, 0, 0 ) 
    743        ! 
    744           IF ( lconv (ji,jj) ) THEN 
    745           ! Unstable conditions 
    746              IF( zdb_bl(ji,jj) > 0._wp ) THEN 
    747              ! calculate pycnocline profiles, no need if zdb_bl <= 0. since profile is zero and arrays have been initialized to zero 
    748                 ztgrad = ( zdt_ml(ji,jj) / zdh(ji,jj) ) 
    749                 zsgrad = ( zds_ml(ji,jj) / zdh(ji,jj) ) 
    750                 zbgrad = ( zdb_ml(ji,jj) / zdh(ji,jj) ) 
    751                 DO jk = 2 , ibld(ji,jj) 
    752                    znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 
    753                    zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    754                    zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    755                    zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    756                 END DO 
    757              ENDIF 
    758           ELSE 
    759           ! stable conditions 
    760           ! if pycnocline profile only defined when depth steady of increasing. 
    761              IF ( zdhdt(ji,jj) >= 0.0 ) THEN        ! Depth increasing, or steady. 
    762                 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
    763                   IF ( zhol(ji,jj) >= 0.5 ) THEN      ! Very stable - 'thick' pycnocline 
    764                       ztgrad = zdt_bl(ji,jj) / zhbl(ji,jj) 
    765                       zsgrad = zds_bl(ji,jj) / zhbl(ji,jj) 
    766                       zbgrad = zdb_bl(ji,jj) / zhbl(ji,jj) 
    767                       DO jk = 2, ibld(ji,jj) 
    768                          znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
    769                          zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
    770                          zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
    771                          zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
    772                       END DO 
    773                   ELSE                                   ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. 
    774                       ztgrad = zdt_bl(ji,jj) / zdh(ji,jj) 
    775                       zsgrad = zds_bl(ji,jj) / zdh(ji,jj) 
    776                       zbgrad = zdb_bl(ji,jj) / zdh(ji,jj) 
    777                       DO jk = 2, ibld(ji,jj) 
    778                          znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 
    779                          zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    780                          zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    781                          zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    782                       END DO 
    783                    ENDIF ! IF (zhol >=0.5) 
    784                 ENDIF    ! IF (zdb_bl> 0.) 
    785              ENDIF       ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero, profile arrays are intialized to zero 
    786           ENDIF          ! IF (lconv) 
    787          ! 
    788        END_2D 
    789 ! 
    790        DO_2D( 0, 0, 0, 0 ) 
    791        ! 
    792           IF ( lconv (ji,jj) ) THEN 
    793           ! Unstable conditions 
    794               zugrad = ( zdu_ml(ji,jj) / zdh(ji,jj) ) + 0.275 * zustar(ji,jj)*zustar(ji,jj) / & 
    795             & (( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) / zla(ji,jj)**(8.0/3.0) 
    796              zvgrad = ( zdv_ml(ji,jj) / zdh(ji,jj) ) + 3.5 * ff_t(ji,jj) * zustke(ji,jj) / & 
    797            & ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
    798              DO jk = 2 , ibld(ji,jj)-1 
    799                 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 
    800                 zdudz_pyc(ji,jj,jk) =  zugrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    801                 zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
    802              END DO 
    803           ELSE 
    804           ! stable conditions 
    805              zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj) 
    806              zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj) 
    807              DO jk = 2, ibld(ji,jj) 
    808                 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
    809                 IF ( znd < 1.0 ) THEN 
    810                    zdudz_pyc(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 ) 
    811                 ELSE 
    812                    zdudz_pyc(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 ) 
    813                 ENDIF 
    814                 zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 ) 
    815              END DO 
    816           ENDIF 
    817          ! 
    818        END_2D 
     688      CALL zdf_osm_external_gradients( ibld+2, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) 
     689      CALL zdf_osm_pycnocline_scalar_profiles( zdtdz_pyc, zdsdz_pyc, zdbdz_pyc, zalpha_pyc ) 
     690      CALL zdf_osm_pycnocline_shear_profiles( zdudz_pyc, zdvdz_pyc ) 
    819691       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    820692       ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship 
    821693       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    822  
    823       ! WHERE ( lconv ) 
    824       !     zdifml_sc = zhml * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird 
    825       !     zvisml_sc = zdifml_sc 
    826       !     zdifpyc_sc = 0.165 * ( zwstrl**3 + zwstrc**3 )**pthird * ( zhbl - zhml ) 
    827       !     zvispyc_sc = 0.142 * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * ( zhbl - zhml ) 
    828       !     zbeta_d_sc = 1.0 - (0.165 / 0.8 * ( zhbl - zhml ) / zhbl )**p2third 
    829       !     zbeta_v_sc = 1.0 -  2.0 * (0.142 /0.375) * (zhbl - zhml ) / zhml 
    830       !  ELSEWHERE 
    831       !     zdifml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) 
    832       !     zvisml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) 
    833       !  ENDWHERE 
    834        DO_2D( 0, 0, 0, 0 ) 
    835           IF ( lconv(ji,jj) ) THEN 
    836             zdifml_sc(ji,jj) = zhml(ji,jj) * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
    837             zvisml_sc(ji,jj) = zdifml_sc(ji,jj) 
    838             zdifpyc_sc(ji,jj) = 0.165 * ( zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) 
    839             zvispyc_sc(ji,jj) = 0.142 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) 
    840             zbeta_d_sc(ji,jj) = 1.0 - (0.165 / 0.8 * zdh(ji,jj) / zhbl(ji,jj) )**p2third 
    841             zbeta_v_sc(ji,jj) = 1.0 -  2.0 * (0.142 /0.375) * zdh(ji,jj) / zhml(ji,jj) 
    842           ELSE 
    843             zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) 
    844             zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) 
    845          END IF 
    846        END_2D 
    847 ! 
    848        DO_2D( 0, 0, 0, 0 ) 
    849           IF ( lconv(ji,jj) ) THEN 
    850              DO jk = 2, imld(ji,jj)   ! mixed layer diffusivity 
    851                  zznd_ml = gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 
    852                  ! 
    853                  zdiffut(ji,jj,jk) = 0.8   * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml    )**1.5 
    854                  ! 
    855                  zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml    ) & 
    856                       &            *                                      ( 1.0 -               0.5 * zznd_ml**2 ) 
    857              END DO 
    858              ! pycnocline - if present linear profile 
    859              IF ( zdh(ji,jj) > 0._wp ) THEN 
    860                 DO jk = imld(ji,jj)+1 , ibld(ji,jj) 
    861                     zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 
    862                     ! 
    863                     zdiffut(ji,jj,jk) = zdifpyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) 
    864                     ! 
    865                     zviscos(ji,jj,jk) = zvispyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) 
    866                 END DO 
    867              ENDIF 
    868              ! Temporay fix to ensure zdiffut is +ve; won't be necessary with ww taken out 
    869              zdiffut(ji,jj,ibld(ji,jj)) = zdhdt(ji,jj)* e3t(ji,jj,ibld(ji,jj),Kmm) 
    870              ! could be taken out, take account of entrainment represents as a diffusivity 
    871              ! should remove w from here, represents entrainment 
    872           ELSE 
    873           ! stable conditions 
    874              DO jk = 2, ibld(ji,jj) 
    875                 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
    876                 zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5 
    877                 zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 ) 
    878              END DO 
    879           ENDIF   ! end if ( lconv ) 
    880 ! 
    881        END_2D 
     694       CALL zdf_osm_diffusivity_viscosity( zdiffut, zviscos ) 
    882695 
    883696       ! 
    … …  
    918731       END_2D 
    919732 
    920  
    921733! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use zvstr since term needs to go to zero as zwstrl goes to zero) 
    922734       WHERE ( lconv ) 
    923           zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke /( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0) ) 
    924           zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / ( zla**(8.0/3.0) + epsln ) 
    925           zsc_vw_1 = ff_t * zhml * zustke**3 * zla**(8.0/3.0) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln ) 
     735          zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / MAX( ( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0) ), 0.2 ) 
     736          zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / MIN( zla**(8.0/3.0) + epsln, 0.12 ) 
     737          zsc_vw_1 = ff_t * zhml * zustke**3 * MIN( zla**(8.0/3.0), 0.12 ) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln ) 
    926738       ELSEWHERE 
    927739          zsc_uw_1 = zustar**2 
    928           zsc_vw_1 = ff_t * zhbl * zustke**3 * zla**(8.0/3.0) / (zvstr**2 + epsln) 
     740          zsc_vw_1 = ff_t * zhbl * zustke**3 * MIN( zla**(8.0/3.0), 0.12 ) / (zvstr**2 + epsln) 
    929741       ENDWHERE 
    930  
     742       IF(ln_dia_osm) THEN 
     743          IF ( iom_use("ghamu_00") ) CALL iom_put( "ghamu_00", wmask*ghamu ) 
     744          IF ( iom_use("ghamv_00") ) CALL iom_put( "ghamv_00", wmask*ghamv ) 
     745       END IF 
    931746       DO_2D( 0, 0, 0, 0 ) 
    932747          IF ( lconv(ji,jj) ) THEN 
    … …  
    970785                zl_l = 2.0 * ( 1.0 - EXP ( - 2.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) )                                           & 
    971786                     &     * ( 1.0 - EXP ( - 5.0 * (     1.0 - zznd_ml          ) ) ) * ( 1.0 + dstokes(ji,jj) / zhml (ji,jj) ) 
    972                 zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( 3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0/2.0) 
     787                zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( -3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0 / 2.0) 
    973788                ! non-gradient buoyancy terms 
    974789                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * 0.5 * zsc_wth_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) 
    975790                ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * 0.5 *  zsc_ws_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) 
    976791             END DO 
    977           ELSE 
     792              
     793             IF ( lpyc(ji,jj) ) THEN 
     794               ztau_sc_u(ji,jj) = zhml(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 
     795               ztau_sc_u(ji,jj) = ztau_sc_u(ji,jj) * ( 1.4 -0.4 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) )**1.5 ) 
     796               zwth_ent =  -0.003 * ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird * ( 1.0 - zdh(ji,jj) /zhbl(ji,jj) ) * zdt_ml(ji,jj)                   
     797               zws_ent =  -0.003 * ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird * ( 1.0 - zdh(ji,jj) /zhbl(ji,jj) ) * zds_ml(ji,jj) 
     798! Cubic profile used for buoyancy term 
     799               za_cubic = 0.755 * ztau_sc_u(ji,jj) 
     800               zb_cubic = 0.25 * ztau_sc_u(ji,jj) 
     801               DO jk = 2, ibld(ji,jj) 
     802                 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 
     803                 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - 0.045 * ( ( zwth_ent * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * MAX( ( 1.75 * zznd_pyc -0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ), 0.0 ) 
     804 
     805                 ghams(ji,jj,jk) = ghams(ji,jj,jk) - 0.045 * ( ( zws_ent * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * MAX( ( 1.75 * zznd_pyc -0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ), 0.0 ) 
     806               END DO 
     807! 
     808               zbuoy_pyc_sc = zalpha_pyc(ji,jj) * zdb_ml(ji,jj) / zdh(ji,jj) + zdbdz_bl_ext(ji,jj) 
     809               zdelta_pyc = ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird / SQRT( MAX( zbuoy_pyc_sc, ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**p2third / zdh(ji,jj)**2 ) ) 
     810! 
     811               zwt_pyc_sc_1 = 0.325 * ( zalpha_pyc(ji,jj) * zdt_ml(ji,jj) / zdh(ji,jj) + zdtdz_bl_ext(ji,jj) ) * zdelta_pyc**2 / zdh(ji,jj) 
     812! 
     813               zws_pyc_sc_1 = 0.325 * ( zalpha_pyc(ji,jj) * zds_ml(ji,jj) / zdh(ji,jj) + zdsdz_bl_ext(ji,jj) ) * zdelta_pyc**2 / zdh(ji,jj) 
     814! 
     815               zzeta_pyc = 0.15 - 0.175 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) )  
     816               DO jk = 2, ibld(ji,jj) 
     817                 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 
     818                 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.05 * zwt_pyc_sc_1 * EXP( -0.25 * ( zznd_pyc / zzeta_pyc )**2 ) * zdh(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 
     819! 
     820                 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.05 * zws_pyc_sc_1 * EXP( -0.25 * ( zznd_pyc / zzeta_pyc )**2 ) * zdh(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 
     821               END DO 
     822            ENDIF ! End of pycnocline                   
     823          ELSE ! lconv test - stable conditions 
    978824             DO jk = 2, ibld(ji,jj) 
    979825                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zsc_wth_1(ji,jj) 
    … …  
    982828          ENDIF 
    983829       END_2D 
    984  
    985830 
    986831       WHERE ( lconv ) 
    … …  
    1011856       END_2D 
    1012857 
     858       DO_2D( 0, 0, 0, 0 ) 
     859        IF ( lpyc(ji,jj) ) THEN 
     860          IF ( j_ddh(ji,jj) == 0 ) THEN 
     861! Place holding code. Parametrization needs checking for these conditions. 
     862            zomega = ( 0.15 * zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.75 * ( zshear(ji,jj)* zhbl(ji,jj) )**pthird )**pthird 
     863            zuw_bse = -0.0035 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdu_ml(ji,jj) 
     864            zvw_bse = -0.0075 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdv_ml(ji,jj) 
     865          ELSE 
     866            zomega = ( 0.15 * zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.75 * ( zshear(ji,jj)* zhbl(ji,jj) )**pthird )**pthird 
     867            zuw_bse = -0.0035 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdu_ml(ji,jj) 
     868            zvw_bse = -0.0075 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdv_ml(ji,jj) 
     869          ENDIF 
     870          zd_cubic = zdh(ji,jj) / zhbl(ji,jj) * zuw0(ji,jj) - ( 2.0 + zdh(ji,jj) /zhml(ji,jj) ) * zuw_bse 
     871          zc_cubic = zuw_bse - zd_cubic 
     872! need ztau_sc_u to be available. Change to array.  
     873          DO jk = imld(ji,jj), ibld(ji,jj) 
     874             zznd_pyc = - ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 
     875             ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.045 * ztau_sc_u(ji,jj)**2 * ( zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) * ( 0.75 + 0.25 * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) 
     876          END DO 
     877          zvw_max = 0.7 * ff_t(ji,jj) * ( zustke(ji,jj) * dstokes(ji,jj) + 0.75 * zustar(ji,jj) * zhml(ji,jj) ) 
     878          zd_cubic = zvw_max * zdh(ji,jj) / zhml(ji,jj) - ( 2.0 + zdh(ji,jj) /zhml(ji,jj) ) * zvw_bse 
     879          zc_cubic = zvw_bse - zd_cubic 
     880          DO jk = imld(ji,jj), ibld(ji,jj) 
     881            zznd_pyc = -( gdepw(ji,jj,jk,Kmm) -zhbl(ji,jj) ) / zdh(ji,jj) 
     882            ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.045 * ztau_sc_u(ji,jj)**2 * ( zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) * ( 0.75 + 0.25 * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) 
     883          END DO 
     884        ENDIF  ! lpyc 
     885       END_2D 
     886 
     887       IF(ln_dia_osm) THEN 
     888          IF ( iom_use("ghamu_0") ) CALL iom_put( "ghamu_0", wmask*ghamu ) 
     889          IF ( iom_use("zsc_uw_1_0") ) CALL iom_put( "zsc_uw_1_0", tmask(:,:,1)*zsc_uw_1 ) 
     890       END IF 
    1013891! Transport term in flux-gradient relationship [note : includes ROI ratio (X0.3) ] 
    1014892 
    1015        WHERE ( lconv ) 
    1016           zsc_wth_1 = zwth0 
    1017           zsc_ws_1 = zws0 
    1018        ELSEWHERE 
    1019           zsc_wth_1 = 2.0 * zwthav 
    1020           zsc_ws_1 = zws0 
    1021        ENDWHERE 
     893       DO_2D( 1, 0, 1, 0 ) 
     894        
     895         IF ( lconv(ji,jj) ) THEN 
     896           zsc_wth_1(ji,jj) = zwth0(ji,jj) / ( 1.0 - 0.56 * EXP( zhol(ji,jj) ) ) 
     897           zsc_ws_1(ji,jj) = zws0(ji,jj) / (1.0 - 0.56 *EXP( zhol(ji,jj) ) ) 
     898           IF ( lpyc(ji,jj) ) THEN 
     899! Pycnocline scales 
     900              zsc_wth_pyc(ji,jj) = -0.2 * zwb0(ji,jj) * zdt_bl(ji,jj) / zdb_bl(ji,jj) 
     901              zsc_ws_pyc(ji,jj) = -0.2 * zwb0(ji,jj) * zds_bl(ji,jj) / zdb_bl(ji,jj) 
     902            ENDIF 
     903         ELSE 
     904           zsc_wth_1(ji,jj) = 2.0 * zwthav(ji,jj) 
     905           zsc_ws_1(ji,jj) = zws0(ji,jj) 
     906         ENDIF 
     907       END_2D 
    1022908 
    1023909       DO_2D( 0, 0, 0, 0 ) 
    … …  
    1035921                    &          * ( 1.0 - EXP ( -15.0 * (         1.0 - zznd_ml    ) ) ) 
    1036922            END DO 
     923! 
     924            IF ( lpyc(ji,jj) ) THEN 
     925! pycnocline 
     926              DO jk = imld(ji,jj), ibld(ji,jj) 
     927                zznd_pyc = - ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 
     928                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 4.0 * zsc_wth_pyc(ji,jj) * ( 0.48 - EXP( -1.5 * ( zznd_pyc -0.3)**2 ) )  
     929                ghams(ji,jj,jk) = ghams(ji,jj,jk) + 4.0 * zsc_ws_pyc(ji,jj) * ( 0.48 - EXP( -1.5 * ( zznd_pyc -0.3)**2 ) )  
     930              END DO 
     931           ENDIF 
    1037932         ELSE 
    1038             DO jk = 2, ibld(ji,jj) 
    1039                zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) 
    1040                znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
    1041                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 
    1042             &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj) 
    1043                ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 
    1044             &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj) 
    1045             END DO 
     933            IF( zdhdt(ji,jj) > 0. ) THEN 
     934              DO jk = 2, ibld(ji,jj) 
     935                 zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) 
     936                 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
     937                 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 
     938              &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj) 
     939                 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 
     940               &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj) 
     941              END DO 
     942            ENDIF 
    1046943         ENDIF 
    1047944       END_2D 
    1048  
    1049945 
    1050946       WHERE ( lconv ) 
    … …  
    1090986          ENDIF 
    1091987       END_2D 
     988 
     989       IF(ln_dia_osm) THEN 
     990          IF ( iom_use("ghamu_f") ) CALL iom_put( "ghamu_f", wmask*ghamu ) 
     991          IF ( iom_use("ghamv_f") ) CALL iom_put( "ghamv_f", wmask*ghamv ) 
     992          IF ( iom_use("zsc_uw_1_f") ) CALL iom_put( "zsc_uw_1_f", tmask(:,:,1)*zsc_uw_1 ) 
     993          IF ( iom_use("zsc_vw_1_f") ) CALL iom_put( "zsc_vw_1_f", tmask(:,:,1)*zsc_vw_1 ) 
     994          IF ( iom_use("zsc_uw_2_f") ) CALL iom_put( "zsc_uw_2_f", tmask(:,:,1)*zsc_uw_2 ) 
     995          IF ( iom_use("zsc_vw_2_f") ) CALL iom_put( "zsc_vw_2_f", tmask(:,:,1)*zsc_vw_2 ) 
     996       END IF 
    1092997! 
    1093998! Make surface forced velocity non-gradient terms go to zero at the base of the mixed layer. 
    1094999 
     1000 
     1001 ! Make surface forced velocity non-gradient terms go to zero at the base of the boundary layer. 
     1002 
    10951003      DO_2D( 0, 0, 0, 0 ) 
    1096          IF ( lconv(ji,jj) ) THEN 
     1004         IF ( .not. lconv(ji,jj) ) THEN 
    10971005            DO jk = 2, ibld(ji,jj) 
    1098                znd = ( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about 
    1099                IF ( znd >= 0.0 ) THEN 
    1100                   ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) 
    1101                   ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) 
    1102                ELSE 
    1103                   ghamu(ji,jj,jk) = 0._wp 
    1104                   ghamv(ji,jj,jk) = 0._wp 
    1105                ENDIF 
    1106             END DO 
    1107          ELSE 
    1108             DO jk = 2, ibld(ji,jj) 
    1109                znd = ( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about 
     1006               znd = ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zhbl(ji,jj) !ALMG to think about 
    11101007               IF ( znd >= 0.0 ) THEN 
    11111008                  ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) ) 
    … …  
    11201017 
    11211018      ! pynocline contributions 
    1122        ! Temporary fix to avoid instabilities when zdb_bl becomes very very small 
    1123        zsc_uw_1 = 0._wp ! 50.0 * zla**(8.0/3.0) * zustar**2 * zhbl / ( zdb_bl + epsln ) 
    11241019       DO_2D( 0, 0, 0, 0 ) 
    1125           DO jk= 2, ibld(ji,jj) 
    1126              znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
    1127              ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk) 
    1128              ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk) 
    1129              ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk) 
    1130              ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) * ( 1.0 - znd )**(7.0/4.0) * zdbdz_pyc(ji,jj,jk) 
    1131              ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk) 
    1132           END DO 
     1020         IF ( .not. lconv(ji,jj) ) THEN 
     1021          IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 
     1022             DO jk= 2, ibld(ji,jj) 
     1023                znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
     1024                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk) 
     1025                ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk) 
     1026                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk) 
     1027                ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk) 
     1028             END DO 
     1029          END IF 
     1030         END IF 
    11331031       END_2D 
    1134  
    1135 ! Entrainment contribution. 
     1032      IF(ln_dia_osm) THEN 
     1033          IF ( iom_use("ghamu_b") ) CALL iom_put( "ghamu_b", wmask*ghamu ) 
     1034          IF ( iom_use("ghamv_b") ) CALL iom_put( "ghamv_b", wmask*ghamv ) 
     1035       END IF 
    11361036 
    11371037       DO_2D( 0, 0, 0, 0 ) 
    1138           IF ( lconv(ji,jj) ) THEN 
    1139             DO jk = 1, imld(ji,jj) - 1 
    1140                znd=gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 
    1141                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * znd 
    1142                ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * znd 
    1143                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * znd 
    1144                ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * znd 
    1145             END DO 
    1146             DO jk = imld(ji,jj), ibld(ji,jj) 
    1147                znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 
    1148                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * ( 1.0 + znd ) 
    1149                ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * ( 1.0 + znd ) 
    1150                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * ( 1.0 + znd ) 
    1151                ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * ( 1.0 + znd ) 
    1152              END DO 
    1153           ENDIF 
    1154           ghamt(ji,jj,ibld(ji,jj)) = 0._wp 
    1155           ghams(ji,jj,ibld(ji,jj)) = 0._wp 
    1156           ghamu(ji,jj,ibld(ji,jj)) = 0._wp 
    1157           ghamv(ji,jj,ibld(ji,jj)) = 0._wp 
     1038          ghamt(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 
     1039          ghams(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 
     1040          ghamu(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 
     1041          ghamv(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 
    11581042       END_2D 
    11591043 
    1160  
     1044       IF(ln_dia_osm) THEN 
     1045          IF ( iom_use("ghamu_1") ) CALL iom_put( "ghamu_1", wmask*ghamu ) 
     1046          IF ( iom_use("ghamv_1") ) CALL iom_put( "ghamv_1", wmask*ghamv ) 
     1047          IF ( iom_use("zdudz_pyc") ) CALL iom_put( "zdudz_pyc", wmask*zdudz_pyc ) 
     1048          IF ( iom_use("zdvdz_pyc") ) CALL iom_put( "zdvdz_pyc", wmask*zdvdz_pyc ) 
     1049          IF ( iom_use("zviscos") ) CALL iom_put( "zviscos", wmask*zviscos ) 
     1050       END IF 
    11611051       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    11621052       ! Need to put in code for contributions that are applied explicitly to 
    … …  
    11801070       IF(ln_dia_osm) THEN 
    11811071          IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc ) 
     1072          IF ( iom_use("zdsdz_pyc") ) CALL iom_put( "zdsdz_pyc", wmask*zdsdz_pyc ) 
     1073          IF ( iom_use("zdbdz_pyc") ) CALL iom_put( "zdbdz_pyc", wmask*zdbdz_pyc ) 
    11821074       END IF 
    11831075 
    … …  
    12221114       END IF ! ln_convmix = .true. 
    12231115 
     1116 
     1117 
     1118       IF ( ln_osm_mle ) THEN  ! set up diffusivity and non-gradient mixing 
     1119          DO_2D( 0, 0, 0, 0 ) 
     1120              IF ( lflux(ji,jj) ) THEN ! MLE mixing extends below boundary layer 
     1121             ! Calculate MLE flux contribution from surface fluxes 
     1122                DO jk = 1, ibld(ji,jj) 
     1123                  znd = gdepw(ji,jj,jk,Kmm) / MAX(zhbl(ji,jj),epsln) 
     1124                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - zwth0(ji,jj) * ( 1.0 - znd ) 
     1125                  ghams(ji,jj,jk) = ghams(ji,jj,jk) - zws0(ji,jj) * ( 1.0 - znd ) 
     1126                 END DO 
     1127                 DO jk = 1, mld_prof(ji,jj) 
     1128                   znd = gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 
     1129                   ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth0(ji,jj) * ( 1.0 - znd ) 
     1130                   ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws0(ji,jj) * ( 1.0 -znd ) 
     1131                 END DO 
     1132         ! Viscosity for MLEs 
     1133                 DO jk = 1, mld_prof(ji,jj) 
     1134                   znd = -gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 
     1135                   zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0 - ( 2.0 * znd + 1.0 )**2 ) * ( 1.0 + 5.0 / 21.0 * ( 2.0 * znd + 1.0 )** 2 ) 
     1136                 END DO 
     1137              ELSE 
     1138! Surface transports limited to OSBL.                  
     1139         ! Viscosity for MLEs 
     1140                 DO jk = 1, mld_prof(ji,jj) 
     1141                   znd = -gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 
     1142                   zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0 - ( 2.0 * znd + 1.0 )**2 ) * ( 1.0 + 5.0 / 21.0 * ( 2.0 * znd + 1.0 )** 2 ) 
     1143                 END DO 
     1144              ENDIF 
     1145          END_2D 
     1146       ENDIF 
     1147 
     1148       IF(ln_dia_osm) THEN 
     1149          IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc ) 
     1150          IF ( iom_use("zdsdz_pyc") ) CALL iom_put( "zdsdz_pyc", wmask*zdsdz_pyc ) 
     1151          IF ( iom_use("zdbdz_pyc") ) CALL iom_put( "zdbdz_pyc", wmask*zdbdz_pyc ) 
     1152       END IF 
     1153 
     1154 
    12241155       ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids 
    1225        CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) 
     1156       !CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) 
    12261157 
    12271158       ! GN 25/8: need to change tmask --> wmask 
    … …  
    12441175            ghams(ji,jj,jk) =  ghams(ji,jj,jk) * tmask(ji,jj,jk) 
    12451176       END_3D 
     1177        ! Lateral boundary conditions on final outputs for hbl,  on T-grid (sign unchanged) 
     1178        CALL lbc_lnk_multi( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. ) 
    12461179        ! Lateral boundary conditions on final outputs for gham[ts],  on W-grid  (sign unchanged) 
    1247         ! Lateral boundary conditions on final outputs for gham[uv],  on [UV]-grid  (sign unchanged) 
    1248         CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp,   & 
    1249          &                  ghamu, 'U', 1.0_wp , ghamv, 'V', 1.0_wp ) 
    1250  
    1251        IF(ln_dia_osm) THEN 
     1180        ! Lateral boundary conditions on final outputs for gham[uv],  on [UV]-grid  (sign changed) 
     1181        CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W',  1.0_wp , ghams, 'W', 1.0_wp,   & 
     1182         &                            ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp ) 
     1183 
     1184      IF(ln_dia_osm) THEN 
    12521185         SELECT CASE (nn_osm_wave) 
    12531186         ! Stokes drift set by assumimg onstant La#=0.3(=0)  or Pierson-Moskovitz spectrum (=1). 
    … …  
    12571190            IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rho0*tmask(:,:,1)*zustar**2*zustke ) 
    12581191         ! Stokes drift read in from sbcwave  (=2). 
    1259          CASE(2) 
    1260             IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd )               ! x surface Stokes drift 
    1261             IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd )               ! y surface Stokes drift 
     1192         CASE(2:3) 
     1193            IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd*umask(:,:,1) )               ! x surface Stokes drift 
     1194            IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd*vmask(:,:,1) )               ! y surface Stokes drift 
     1195            IF ( iom_use("wmp") ) CALL iom_put( "wmp", wmp*tmask(:,:,1) )                   ! wave mean period 
     1196            IF ( iom_use("hsw") ) CALL iom_put( "hsw", hsw*tmask(:,:,1) )                   ! significant wave height 
     1197            IF ( iom_use("wmp_NP") ) CALL iom_put( "wmp_NP", (2.*rpi*1.026/(0.877*grav) )*wndm*tmask(:,:,1) )                  ! wave mean period from NP spectrum 
     1198            IF ( iom_use("hsw_NP") ) CALL iom_put( "hsw_NP", (0.22/grav)*wndm**2*tmask(:,:,1) )                   ! significant wave height from NP spectrum 
     1199            IF ( iom_use("wndm") ) CALL iom_put( "wndm", wndm*tmask(:,:,1) )                   ! U_10 
    12621200            IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rho0*tmask(:,:,1)*zustar**2* & 
    12631201                 & SQRT(ut0sd**2 + vt0sd**2 ) ) 
    … …  
    12701208         IF ( iom_use("zws0") ) CALL iom_put( "zws0", tmask(:,:,1)*zws0 )                ! <Sw_0> 
    12711209         IF ( iom_use("hbl") ) CALL iom_put( "hbl", tmask(:,:,1)*hbl )                  ! boundary-layer depth 
    1272          IF ( iom_use("hbli") ) CALL iom_put( "hbli", tmask(:,:,1)*hbli )               ! Initial boundary-layer depth 
     1210         IF ( iom_use("ibld") ) CALL iom_put( "ibld", tmask(:,:,1)*ibld )               ! boundary-layer max k 
     1211         IF ( iom_use("zdt_bl") ) CALL iom_put( "zdt_bl", tmask(:,:,1)*zdt_bl )           ! dt at ml base 
     1212         IF ( iom_use("zds_bl") ) CALL iom_put( "zds_bl", tmask(:,:,1)*zds_bl )           ! ds at ml base 
     1213         IF ( iom_use("zdb_bl") ) CALL iom_put( "zdb_bl", tmask(:,:,1)*zdb_bl )           ! db at ml base 
     1214         IF ( iom_use("zdu_bl") ) CALL iom_put( "zdu_bl", tmask(:,:,1)*zdu_bl )           ! du at ml base 
     1215         IF ( iom_use("zdv_bl") ) CALL iom_put( "zdv_bl", tmask(:,:,1)*zdv_bl )           ! dv at ml base 
     1216         IF ( iom_use("dh") ) CALL iom_put( "dh", tmask(:,:,1)*dh )               ! Initial boundary-layer depth 
     1217         IF ( iom_use("hml") ) CALL iom_put( "hml", tmask(:,:,1)*hml )               ! Initial boundary-layer depth 
    12731218         IF ( iom_use("dstokes") ) CALL iom_put( "dstokes", tmask(:,:,1)*dstokes )      ! Stokes drift penetration depth 
    12741219         IF ( iom_use("zustke") ) CALL iom_put( "zustke", tmask(:,:,1)*zustke )            ! Stokes drift magnitude at T-points 
    … …  
    12761221         IF ( iom_use("zwstrl") ) CALL iom_put( "zwstrl", tmask(:,:,1)*zwstrl )         ! Langmuir velocity scale 
    12771222         IF ( iom_use("zustar") ) CALL iom_put( "zustar", tmask(:,:,1)*zustar )         ! friction velocity scale 
     1223         IF ( iom_use("zvstr") ) CALL iom_put( "zvstr", tmask(:,:,1)*zvstr )         ! mixed velocity scale 
     1224         IF ( iom_use("zla") ) CALL iom_put( "zla", tmask(:,:,1)*zla )         ! langmuir # 
    12781225         IF ( iom_use("wind_power") ) CALL iom_put( "wind_power", 1000.*rho0*tmask(:,:,1)*zustar**3 ) ! BL depth internal to zdf_osm routine 
    12791226         IF ( iom_use("wind_wave_power") ) CALL iom_put( "wind_wave_power", 1000.*rho0*tmask(:,:,1)*zustar**2*zustke ) 
    12801227         IF ( iom_use("zhbl") ) CALL iom_put( "zhbl", tmask(:,:,1)*zhbl )               ! BL depth internal to zdf_osm routine 
    12811228         IF ( iom_use("zhml") ) CALL iom_put( "zhml", tmask(:,:,1)*zhml )               ! ML depth internal to zdf_osm routine 
    1282          IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh )               ! ML depth internal to zdf_osm routine 
     1229         IF ( iom_use("imld") ) CALL iom_put( "imld", tmask(:,:,1)*imld )               ! index for ML depth internal to zdf_osm routine 
     1230         IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh )                  ! pyc thicknessh internal to zdf_osm routine 
    12831231         IF ( iom_use("zhol") ) CALL iom_put( "zhol", tmask(:,:,1)*zhol )               ! ML depth internal to zdf_osm routine 
    1284          IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav )               ! ML depth internal to zdf_osm routine 
    1285          IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent )               ! ML depth internal to zdf_osm routine 
    1286          IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml )               ! average T in ML 
     1232         IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav )         ! upward BL-avged turb temp flux 
     1233         IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent )   ! upward turb temp entrainment flux 
     1234         IF ( iom_use("zwb_ent") ) CALL iom_put( "zwb_ent", tmask(:,:,1)*zwb_ent )      ! upward turb buoyancy entrainment flux 
     1235         IF ( iom_use("zws_ent") ) CALL iom_put( "zws_ent", tmask(:,:,1)*zws_ent )      ! upward turb salinity entrainment flux 
     1236         IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml )            ! average T in ML 
     1237 
     1238         IF ( iom_use("hmle") ) CALL iom_put( "hmle", tmask(:,:,1)*hmle )               ! FK layer depth 
     1239         IF ( iom_use("zmld") ) CALL iom_put( "zmld", tmask(:,:,1)*zmld )               ! FK target layer depth 
     1240         IF ( iom_use("zwb_fk") ) CALL iom_put( "zwb_fk", tmask(:,:,1)*zwb_fk )         ! FK b flux 
     1241         IF ( iom_use("zwb_fk_b") ) CALL iom_put( "zwb_fk_b", tmask(:,:,1)*zwb_fk_b )   ! FK b flux averaged over ML 
     1242         IF ( iom_use("mld_prof") ) CALL iom_put( "mld_prof", tmask(:,:,1)*mld_prof )! FK layer max k 
     1243         IF ( iom_use("zdtdx") ) CALL iom_put( "zdtdx", umask(:,:,1)*zdtdx )            ! FK dtdx at u-pt 
     1244         IF ( iom_use("zdtdy") ) CALL iom_put( "zdtdy", vmask(:,:,1)*zdtdy )            ! FK dtdy at v-pt 
     1245         IF ( iom_use("zdsdx") ) CALL iom_put( "zdsdx", umask(:,:,1)*zdsdx )            ! FK dtdx at u-pt 
     1246         IF ( iom_use("zdsdy") ) CALL iom_put( "zdsdy", vmask(:,:,1)*zdsdy )            ! FK dsdy at v-pt 
     1247         IF ( iom_use("dbdx_mle") ) CALL iom_put( "dbdx_mle", umask(:,:,1)*dbdx_mle )            ! FK dbdx at u-pt 
     1248         IF ( iom_use("dbdy_mle") ) CALL iom_put( "dbdy_mle", vmask(:,:,1)*dbdy_mle )            ! FK dbdy at v-pt 
     1249         IF ( iom_use("zdiff_mle") ) CALL iom_put( "zdiff_mle", tmask(:,:,1)*zdiff_mle )! FK diff in MLE at t-pt 
     1250         IF ( iom_use("zvel_mle") ) CALL iom_put( "zvel_mle", tmask(:,:,1)*zdiff_mle )! FK diff in MLE at t-pt 
     1251 
    12871252      END IF 
    1288       ! Lateral boundary conditions on p_avt  (sign unchanged) 
    1289       CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1.0_wp ) 
     1253 
     1254CONTAINS 
     1255! subroutine code changed, needs syntax checking. 
     1256  SUBROUTINE zdf_osm_diffusivity_viscosity( zdiffut, zviscos ) 
     1257 
     1258!!--------------------------------------------------------------------- 
     1259     !!                   ***  ROUTINE zdf_osm_diffusivity_viscosity  *** 
     1260     !! 
     1261     !! ** Purpose : Determines the eddy diffusivity and eddy viscosity profiles in the mixed layer and the pycnocline. 
     1262     !! 
     1263     !! ** Method  :  
     1264     !! 
     1265     !! !!---------------------------------------------------------------------- 
     1266     REAL(wp), DIMENSION(:,:,:) :: zdiffut 
     1267     REAL(wp), DIMENSION(:,:,:) :: zviscos 
     1268! local 
     1269 
     1270! Scales used to calculate eddy diffusivity and viscosity profiles 
     1271      REAL(wp), DIMENSION(jpi,jpj) :: zdifml_sc, zvisml_sc 
     1272      REAL(wp), DIMENSION(jpi,jpj) :: zdifpyc_n_sc, zdifpyc_s_sc, zdifpyc_shr 
     1273      REAL(wp), DIMENSION(jpi,jpj) :: zvispyc_n_sc, zvispyc_s_sc,zvispyc_shr 
     1274      REAL(wp), DIMENSION(jpi,jpj) :: zbeta_d_sc, zbeta_v_sc 
     1275! 
     1276      REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac 
     1277       
     1278      REAL(wp), PARAMETER :: rn_dif_ml = 0.8, rn_vis_ml = 0.375 
     1279      REAL(wp), PARAMETER :: rn_dif_pyc = 0.15, rn_vis_pyc = 0.142 
     1280      REAL(wp), PARAMETER :: rn_vispyc_shr = 0.15 
     1281       
     1282      DO_2D( 0, 0, 0, 0 ) 
     1283          IF ( lconv(ji,jj) ) THEN 
     1284           
     1285            zvel_sc_pyc = ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.25 * zshear(ji,jj) * zhbl(ji,jj) )**pthird 
     1286            zvel_sc_ml = ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
     1287            zstab_fac = ( zhml(ji,jj) / zvel_sc_ml * ( 1.4 - 0.4 / ( 1.0 + EXP(-3.5 * LOG10(-zhol(ji,jj) ) ) )**1.25 ) )**2 
     1288 
     1289            zdifml_sc(ji,jj) = rn_dif_ml * zhml(ji,jj) * zvel_sc_ml 
     1290            zvisml_sc(ji,jj) = rn_vis_ml * zdifml_sc(ji,jj) 
     1291 
     1292            IF ( lpyc(ji,jj) ) THEN 
     1293              zdifpyc_n_sc(ji,jj) =  rn_dif_pyc * zvel_sc_ml * zdh(ji,jj) 
     1294 
     1295              IF ( lshear(ji,jj) .and. j_ddh(ji,jj) == 1 ) THEN 
     1296                zdifpyc_n_sc(ji,jj) = zdifpyc_n_sc(ji,jj) + rn_vispyc_shr * ( zshear(ji,jj) * zhbl(ji,jj) )**pthird * zhbl(ji,jj) 
     1297              ENDIF 
     1298             
     1299              zdifpyc_s_sc(ji,jj) = zwb_ent(ji,jj) + 0.0025 * zvel_sc_pyc * ( zhbl(ji,jj) / zdh(ji,jj) - 1.0 ) * ( zb_ml(ji,jj) - zb_bl(ji,jj) ) 
     1300              zdifpyc_s_sc(ji,jj) = 0.09 * zdifpyc_s_sc(ji,jj) * zstab_fac 
     1301              zdifpyc_s_sc(ji,jj) = MAX( zdifpyc_s_sc(ji,jj), -0.5 * zdifpyc_n_sc(ji,jj) ) 
     1302               
     1303              zvispyc_n_sc(ji,jj) = 0.09 * zvel_sc_pyc * ( 1.0 - zhbl(ji,jj) / zdh(ji,jj) )**2 * ( 0.005 * ( zu_ml(ji,jj)-zu_bl(ji,jj) )**2 + 0.0075 * ( zv_ml(ji,jj)-zv_bl(ji,jj) )**2 ) / zdh(ji,jj) 
     1304              zvispyc_n_sc(ji,jj) = rn_vis_pyc * zvel_sc_ml * zdh(ji,jj) + zvispyc_n_sc(ji,jj) * zstab_fac 
     1305              IF ( lshear(ji,jj) .and. j_ddh(ji,jj) == 1 ) THEN 
     1306                zvispyc_n_sc(ji,jj) = zvispyc_n_sc(ji,jj) + rn_vispyc_shr * ( zshear(ji,jj) * zhbl(ji,jj ) )**pthird * zhbl(ji,jj) 
     1307              ENDIF 
     1308              
     1309              zvispyc_s_sc(ji,jj) = 0.09 * ( zwb_min(ji,jj) + 0.0025 * zvel_sc_pyc * ( zhbl(ji,jj) / zdh(ji,jj) - 1.0 ) * ( zb_ml(ji,jj) - zb_bl(ji,jj) ) ) 
     1310              zvispyc_s_sc(ji,jj) = zvispyc_s_sc(ji,jj) * zstab_fac 
     1311              zvispyc_s_sc(ji,jj) = MAX( zvispyc_s_sc(ji,jj), -0.5 * zvispyc_s_sc(ji,jj) ) 
     1312 
     1313              zbeta_d_sc(ji,jj) = 1.0 - ( ( zdifpyc_n_sc(ji,jj) + 1.4 * zdifpyc_s_sc(ji,jj) ) / ( zdifml_sc(ji,jj) + epsln ) )**p2third 
     1314              zbeta_v_sc(ji,jj) = 1.0 -  2.0 * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / ( zvisml_sc(ji,jj) + epsln ) 
     1315            ELSE 
     1316              zbeta_d_sc(ji,jj) = 1.0 
     1317              zbeta_v_sc(ji,jj) = 1.0 
     1318            ENDIF 
     1319          ELSE 
     1320            zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * MAX( EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) 
     1321            zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * MAX( EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) 
     1322          END IF 
     1323      END_2D 
     1324! 
     1325       DO_2D( 0, 0, 0, 0 ) 
     1326          IF ( lconv(ji,jj) ) THEN 
     1327             DO jk = 2, imld(ji,jj)   ! mixed layer diffusivity 
     1328                 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 
     1329                 ! 
     1330                 zdiffut(ji,jj,jk) = zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 
     1331                 ! 
     1332                 zviscos(ji,jj,jk) = zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml ) & 
     1333   &            *                                      ( 1.0 - 0.5 * zznd_ml**2 ) 
     1334             END DO 
     1335! pycnocline 
     1336             IF ( lpyc(ji,jj) ) THEN 
     1337! Diffusivity profile in the pycnocline given by cubic polynomial. 
     1338                za_cubic = 0.5 
     1339                zb_cubic = -1.75 * zdifpyc_s_sc(ji,jj) / zdifpyc_n_sc(ji,jj) 
     1340                zd_cubic = ( zdh(ji,jj) * zdifml_sc(ji,jj) / zhml(ji,jj) * SQRT( 1.0 - zbeta_d_sc(ji,jj) ) * ( 2.5 * zbeta_d_sc(ji,jj) - 1.0 ) & 
     1341                     & - 0.85 * zdifpyc_s_sc(ji,jj) ) / MAX(zdifpyc_n_sc(ji,jj), 1.e-8) 
     1342                zd_cubic = zd_cubic - zb_cubic - 2.0 * ( 1.0 - za_cubic  - zb_cubic ) 
     1343                zc_cubic = 1.0 - za_cubic - zb_cubic - zd_cubic 
     1344                DO jk = imld(ji,jj) , ibld(ji,jj) 
     1345                  zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / MAX(zdh(ji,jj), 1.e-6) 
     1346                      ! 
     1347                  zdiffut(ji,jj,jk) = zdifpyc_n_sc(ji,jj) * ( za_cubic + zb_cubic * zznd_pyc + zc_cubic * zznd_pyc**2 +   zd_cubic * zznd_pyc**3 ) 
     1348 
     1349                  zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdifpyc_s_sc(ji,jj) * ( 1.75 * zznd_pyc - 0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ) 
     1350                END DO 
     1351 ! viscosity profiles. 
     1352                za_cubic = 0.5 
     1353                zb_cubic = -1.75 * zvispyc_s_sc(ji,jj) / zvispyc_n_sc(ji,jj) 
     1354                zd_cubic = ( 0.5 * zvisml_sc(ji,jj) * zdh(ji,jj) / zhml(ji,jj) - 0.85 * zvispyc_s_sc(ji,jj)  )  / MAX(zvispyc_n_sc(ji,jj), 1.e-8) 
     1355                zd_cubic = zd_cubic - zb_cubic - 2.0 * ( 1.0 - za_cubic - zd_cubic ) 
     1356                zc_cubic = 1.0 - za_cubic - zb_cubic - zd_cubic 
     1357                DO jk = imld(ji,jj) , ibld(ji,jj) 
     1358                   zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / MAX(zdh(ji,jj), 1.e-6) 
     1359                    zviscos(ji,jj,jk) = zvispyc_n_sc(ji,jj) * ( za_cubic + zb_cubic * zznd_pyc + zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) 
     1360                    zviscos(ji,jj,jk) = zviscos(ji,jj,jk) + zvispyc_s_sc(ji,jj) * ( 1.75 * zznd_pyc - 0.15 * zznd_pyc**2 -0.2 * zznd_pyc**3 ) 
     1361                END DO 
     1362                IF ( zdhdt(ji,jj) > 0._wp ) THEN 
     1363                 zdiffut(ji,jj,ibld(ji,jj)+1) = MAX( 0.5 * zdhdt(ji,jj) * e3w(ji,jj,ibld(ji,jj)+1,Kmm), 1.0e-6 ) 
     1364                 zviscos(ji,jj,ibld(ji,jj)+1) = MAX( 0.5 * zdhdt(ji,jj) * e3w(ji,jj,ibld(ji,jj)+1,Kmm), 1.0e-6 ) 
     1365                ELSE 
     1366                  zdiffut(ji,jj,ibld(ji,jj)) = 0._wp 
     1367                  zviscos(ji,jj,ibld(ji,jj)) = 0._wp 
     1368                ENDIF 
     1369             ENDIF 
     1370          ELSE 
     1371          ! stable conditions 
     1372             DO jk = 2, ibld(ji,jj) 
     1373                zznd_ml = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
     1374                zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5 
     1375                zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 ) 
     1376             END DO 
     1377 
     1378             IF ( zdhdt(ji,jj) > 0._wp ) THEN 
     1379                zdiffut(ji,jj,ibld(ji,jj)) = MAX(zdhdt(ji,jj), 1.0e-6) * e3w(ji, jj, ibld(ji,jj), Kmm) 
     1380                zviscos(ji,jj,ibld(ji,jj)) = MAX(zdhdt(ji,jj), 1.0e-6) * e3w(ji, jj, ibld(ji,jj), Kmm) 
     1381             ENDIF 
     1382          ENDIF   ! end if ( lconv ) 
     1383          ! 
     1384       END_2D 
     1385        
     1386  END SUBROUTINE zdf_osm_diffusivity_viscosity 
     1387   
     1388  SUBROUTINE zdf_osm_osbl_state( lconv, lshear, j_ddh, zwb_ent, zwb_min, zshear, zri_i ) 
     1389 
     1390!!--------------------------------------------------------------------- 
     1391     !!                   ***  ROUTINE zdf_osm_osbl_state  *** 
     1392     !! 
     1393     !! ** Purpose : Determines the state of the OSBL, stable/unstable, shear/ noshear. Also determines shear production, entrainment buoyancy flux and interfacial Richardson number 
     1394     !! 
     1395     !! ** Method  :  
     1396     !! 
     1397     !! !!---------------------------------------------------------------------- 
     1398 
     1399     INTEGER, DIMENSION(jpi,jpj) :: j_ddh  ! j_ddh = 0, active shear layer; j_ddh=1, shear layer not active; j_ddh=2 shear production low. 
     1400      
     1401     LOGICAL, DIMENSION(jpi,jpj) :: lconv, lshear 
     1402 
     1403     REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent, zwb_min ! Buoyancy fluxes at base of well-mixed layer. 
     1404     REAL(wp), DIMENSION(jpi,jpj) :: zshear  ! production of TKE due to shear across the pycnocline 
     1405     REAL(wp), DIMENSION(jpi,jpj) :: zri_i  ! Interfacial Richardson Number 
     1406 
     1407! Local Variables 
     1408 
     1409     INTEGER :: jj, ji 
     1410      
     1411     REAL(wp), DIMENSION(jpi,jpj) :: zekman 
     1412     REAL(wp) :: zri_p, zri_b   ! Richardson numbers 
     1413     REAL(wp) :: zshear_u, zshear_v, zwb_shr 
     1414     REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes 
     1415 
     1416     REAL, PARAMETER :: za_shr = 0.4, zb_shr = 6.5, za_wb_s = 0.1 
     1417     REAL, PARAMETER :: rn_ri_thres_a = 0.5, rn_ri_thresh_b = 0.59 
     1418     REAL, PARAMETER :: zalpha_c = 0.2, zalpha_lc = 0.04      
     1419     REAL, PARAMETER :: zalpha_ls = 0.06, zalpha_s = 0.15 
     1420     REAL, PARAMETER :: rn_ri_p_thresh = 27.0 
     1421     REAL, PARAMETER :: zrot=0._wp  ! dummy rotation rate of surface stress. 
     1422      
     1423! Determins stability and set flag lconv 
     1424     DO_2D( 0, 0, 0, 0 ) 
     1425      IF ( zhol(ji,jj) < 0._wp ) THEN 
     1426         lconv(ji,jj) = .TRUE. 
     1427       ELSE 
     1428          lconv(ji,jj) = .FALSE. 
     1429       ENDIF 
     1430     END_2D 
     1431  
     1432     zekman(:,:) = EXP( - 4.0 * ABS( ff_t(:,:) ) * zhbl(:,:) / MAX(zustar(:,:), 1.e-8 ) ) 
     1433      
     1434     WHERE ( lconv ) 
     1435       zri_i = zdb_ml * zhml**2 / MAX( ( zvstr**3 + 0.5 * zwstrc**3 )**p2third * zdh, 1.e-12 ) 
     1436     END WHERE 
     1437 
     1438     zshear(:,:) = 0._wp 
     1439     j_ddh(:,:) = 1      
     1440  
     1441     DO_2D( 0, 0, 0, 0 ) 
     1442      IF ( lconv(ji,jj) ) THEN 
     1443         IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
     1444           zri_p = MAX (  SQRT( zdb_bl(ji,jj) * zdh(ji,jj) / MAX( zdu_bl(ji,jj)**2 + zdv_bl(ji,jj)**2, 1.e-8) )  *  ( zhbl(ji,jj) / zdh(ji,jj) ) * ( zvstr(ji,jj) / MAX( zustar(ji,jj), 1.e-6 ) )**2 & 
     1445                & / MAX( zekman(ji,jj), 1.e-6 )  , 5._wp ) 
     1446          
     1447           zri_b = zdb_ml(ji,jj) * zdh(ji,jj) / MAX( zdu_ml(ji,jj)**2 + zdv_ml(ji,jj)**2, 1.e-8 ) 
     1448                      
     1449           zshear(ji,jj) = za_shr * zekman(ji,jj) * ( MAX( zustar(ji,jj)**2 * zdu_ml(ji,jj) / zhbl(ji,jj), 0._wp ) + zb_shr * MAX( -ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) * zdv_ml(ji,jj) / zhbl(ji,jj), 0._wp ) ) 
     1450!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1451! Test ensures j_ddh=0 is not selected. Change to zri_p<27 when  ! 
     1452! full code available                                          ! 
     1453!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1454           IF ( zri_p < -rn_ri_p_thresh .and. zshear(ji,jj) > 0._wp ) THEN 
     1455! Growing shear layer 
     1456             j_ddh(ji,jj) = 0 
     1457             lshear(ji,jj) = .TRUE. 
     1458           ELSE 
     1459             j_ddh(ji,jj) = 1 
     1460             IF ( zri_b <= 1.5 .and. zshear(ji,jj) > 0._wp ) THEN 
     1461! shear production large enough to determine layer charcteristics, but can't maintain a shear layer. 
     1462               lshear(ji,jj) = .TRUE. 
     1463             ELSE 
     1464! Shear production may not be zero, but is small and doesn't determine characteristics of pycnocline. 
     1465               zshear(ji,jj) = 0.5 * zshear(ji,jj) 
     1466               lshear(ji,jj) = .FALSE. 
     1467             ENDIF  
     1468           ENDIF                 
     1469         ELSE                ! zdb_bl test, note zshear set to zero 
     1470           j_ddh(ji,jj) = 2 
     1471           lshear(ji,jj) = .FALSE. 
     1472         ENDIF 
     1473       ENDIF 
     1474     END_2D 
     1475  
     1476! Calculate entrainment buoyancy flux due to surface fluxes. 
     1477 
     1478     DO_2D( 0, 0, 0, 0 ) 
     1479      IF ( lconv(ji,jj) ) THEN 
     1480        zwcor = ABS(ff_t(ji,jj)) * zhbl(ji,jj) + epsln 
     1481        zrf_conv = TANH( ( zwstrc(ji,jj) / zwcor )**0.69 ) 
     1482        zrf_shear = TANH( ( zustar(ji,jj) / zwcor )**0.69 ) 
     1483        zrf_langmuir = TANH( ( zwstrl(ji,jj) / zwcor )**0.69 ) 
     1484        IF (nn_osm_SD_reduce > 0 ) THEN 
     1485        ! Effective Stokes drift already reduced from surface value 
     1486           zr_stokes = 1.0_wp 
     1487        ELSE 
     1488         ! Effective Stokes drift only reduced by factor rn_zdfodm_adjust_sd, 
     1489          ! requires further reduction where BL is deep 
     1490           zr_stokes = 1.0 - EXP( -25.0 * dstokes(ji,jj) / hbl(ji,jj) & 
     1491         &                  * ( 1.0 + 4.0 * dstokes(ji,jj) / hbl(ji,jj) ) ) 
     1492        END IF 
     1493        zwb_ent(ji,jj) = - 2.0 * 0.2 * zrf_conv * zwbav(ji,jj) & 
     1494               &                  - 0.15 * zrf_shear * zustar(ji,jj)**3 /zhml(ji,jj) & 
     1495               &         + zr_stokes * ( 0.15 * EXP( -1.5 * zla(ji,jj) ) * zrf_shear * zustar(ji,jj)**3 & 
     1496               &                                         - zrf_langmuir * 0.03 * zwstrl(ji,jj)**3 ) / zhml(ji,jj) 
     1497          ! 
     1498      ENDIF 
     1499     END_2D 
     1500 
     1501     zwb_min(:,:) = 0._wp 
     1502 
     1503     DO_2D( 0, 0, 0, 0 ) 
     1504      IF ( lshear(ji,jj) ) THEN 
     1505        IF ( lconv(ji,jj) ) THEN 
     1506! Unstable OSBL 
     1507           zwb_shr = -za_wb_s * zshear(ji,jj) 
     1508           IF ( j_ddh(ji,jj) == 0 ) THEN 
     1509 
     1510! Developing shear layer, additional shear production possible. 
     1511 
     1512             zshear_u = MAX( zustar(ji,jj)**2 * zdu_ml(ji,jj) /  zhbl(ji,jj), 0._wp ) 
     1513             zshear(ji,jj) = zshear(ji,jj) + zshear_u * ( 1.0 - MIN( zri_p / rn_ri_p_thresh, 1.d0 ) ) 
     1514             zshear(ji,jj) = MIN( zshear(ji,jj), zshear_u ) 
     1515              
     1516             zwb_shr = -za_wb_s * zshear(ji,jj) 
     1517              
     1518           ENDIF                 
     1519           zwb_ent(ji,jj) = zwb_ent(ji,jj) + zwb_shr 
     1520           zwb_min(ji,jj) = zwb_ent(ji,jj) + zdh(ji,jj) / zhbl(ji,jj) * zwb0(ji,jj) 
     1521        ELSE    ! IF ( lconv ) THEN - ENDIF 
     1522! Stable OSBL  - shear production not coded for first attempt.            
     1523        ENDIF  ! lconv 
     1524      ELSE  ! lshear 
     1525        IF ( lconv(ji,jj) ) THEN 
     1526! Unstable OSBL 
     1527           zwb_shr = -za_wb_s * zshear(ji,jj) 
     1528           zwb_ent(ji,jj) = zwb_ent(ji,jj) + zwb_shr 
     1529           zwb_min(ji,jj) = zwb_ent(ji,jj) + zdh(ji,jj) / zhbl(ji,jj) * zwb0(ji,jj) 
     1530        ENDIF  ! lconv 
     1531      ENDIF    ! lshear 
     1532     END_2D 
     1533   END SUBROUTINE zdf_osm_osbl_state 
     1534      
     1535      
     1536   SUBROUTINE zdf_osm_vertical_average( jnlev_av, jp_ext, zt, zs, zb, zu, zv, zdt, zds, zdb, zdu, zdv ) 
     1537     !!--------------------------------------------------------------------- 
     1538     !!                   ***  ROUTINE zdf_vertical_average  *** 
     1539     !! 
     1540     !! ** Purpose : Determines vertical averages from surface to jnlev. 
     1541     !! 
     1542     !! ** Method  : Averages are calculated from the surface to jnlev. 
     1543     !!              The external level used to calculate differences is ibld+ibld_ext 
     1544     !! 
     1545     !!---------------------------------------------------------------------- 
     1546 
     1547        INTEGER, DIMENSION(jpi,jpj) :: jnlev_av  ! Number of levels to average over. 
     1548        INTEGER, DIMENSION(jpi,jpj) :: jp_ext 
     1549 
     1550        ! Alan: do we need zb? 
     1551        REAL(wp), DIMENSION(jpi,jpj) :: zt, zs, zb        ! Average temperature and salinity 
     1552        REAL(wp), DIMENSION(jpi,jpj) :: zu,zv         ! Average current components 
     1553        REAL(wp), DIMENSION(jpi,jpj) :: zdt, zds, zdb ! Difference between average and value at base of OSBL 
     1554        REAL(wp), DIMENSION(jpi,jpj) :: zdu, zdv      ! Difference for velocity components. 
     1555 
     1556        INTEGER :: jk, ji, jj, ibld_ext 
     1557        REAL(wp) :: zthick, zthermal, zbeta 
     1558 
     1559 
     1560        zt   = 0._wp 
     1561        zs   = 0._wp 
     1562        zu   = 0._wp 
     1563        zv   = 0._wp 
     1564        DO_2D( 0, 0, 0, 0 ) 
     1565         zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 
     1566         zbeta    = rab_n(ji,jj,1,jp_sal) 
     1567            ! average over depth of boundary layer 
     1568         zthick = epsln 
     1569         DO jk = 2, jnlev_av(ji,jj) 
     1570            zthick = zthick + e3t(ji,jj,jk,Kmm) 
     1571            zt(ji,jj)   = zt(ji,jj)  + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 
     1572            zs(ji,jj)   = zs(ji,jj)  + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 
     1573            zu(ji,jj)   = zu(ji,jj)  + e3t(ji,jj,jk,Kmm) & 
     1574                  &            * ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) & 
     1575                  &            / MAX( 1. , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) 
     1576            zv(ji,jj)   = zv(ji,jj)  + e3t(ji,jj,jk,Kmm) & 
     1577                  &            * ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) & 
     1578                  &            / MAX( 1. , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) 
     1579         END DO 
     1580         zt(ji,jj) = zt(ji,jj) / zthick 
     1581         zs(ji,jj) = zs(ji,jj) / zthick 
     1582         zu(ji,jj) = zu(ji,jj) / zthick 
     1583         zv(ji,jj) = zv(ji,jj) / zthick 
     1584         zb(ji,jj) = grav * zthermal * zt(ji,jj) - grav * zbeta * zs(ji,jj) 
     1585         ibld_ext = jnlev_av(ji,jj) + jp_ext(ji,jj) 
     1586         IF ( ibld_ext < mbkt(ji,jj) ) THEN 
     1587           zdt(ji,jj) = zt(ji,jj) - ts(ji,jj,ibld_ext,jp_tem,Kmm) 
     1588           zds(ji,jj) = zs(ji,jj) - ts(ji,jj,ibld_ext,jp_sal,Kmm) 
     1589           zdu(ji,jj) = zu(ji,jj) - ( uu(ji,jj,ibld_ext,Kbb) + uu(ji-1,jj,ibld_ext,Kbb ) ) & 
     1590                  &    / MAX(1. , umask(ji,jj,ibld_ext ) + umask(ji-1,jj,ibld_ext ) ) 
     1591           zdv(ji,jj) = zv(ji,jj) - ( vv(ji,jj,ibld_ext,Kbb) + vv(ji,jj-1,ibld_ext,Kbb ) ) & 
     1592                  &   / MAX(1. , vmask(ji,jj,ibld_ext ) + vmask(ji,jj-1,ibld_ext ) ) 
     1593           zdb(ji,jj) = grav * zthermal * zdt(ji,jj) - grav * zbeta * zds(ji,jj) 
     1594         ELSE 
     1595           zdt(ji,jj) = 0._wp 
     1596           zds(ji,jj) = 0._wp 
     1597           zdu(ji,jj) = 0._wp 
     1598           zdv(ji,jj) = 0._wp 
     1599           zdb(ji,jj) = 0._wp 
     1600         ENDIF 
     1601        END_2D 
     1602   END SUBROUTINE zdf_osm_vertical_average 
     1603 
     1604   SUBROUTINE zdf_osm_velocity_rotation( zcos_w, zsin_w, zu, zv, zdu, zdv ) 
     1605     !!--------------------------------------------------------------------- 
     1606     !!                   ***  ROUTINE zdf_velocity_rotation  *** 
     1607     !! 
     1608     !! ** Purpose : Rotates frame of reference of averaged velocity components. 
     1609     !! 
     1610     !! ** Method  : The velocity components are rotated into frame specified by zcos_w and zsin_w 
     1611     !! 
     1612     !!---------------------------------------------------------------------- 
     1613 
     1614        REAL(wp), DIMENSION(jpi,jpj) :: zcos_w, zsin_w       ! Cos and Sin of rotation angle 
     1615        REAL(wp), DIMENSION(jpi,jpj) :: zu, zv               ! Components of current 
     1616        REAL(wp), DIMENSION(jpi,jpj) :: zdu, zdv             ! Change in velocity components across pycnocline 
     1617 
     1618        INTEGER :: ji, jj 
     1619        REAL(wp) :: ztemp 
     1620 
     1621        DO_2D( 0, 0, 0, 0 ) 
     1622           ztemp = zu(ji,jj) 
     1623           zu(ji,jj) = zu(ji,jj) * zcos_w(ji,jj) + zv(ji,jj) * zsin_w(ji,jj) 
     1624           zv(ji,jj) = zv(ji,jj) * zcos_w(ji,jj) - ztemp * zsin_w(ji,jj) 
     1625           ztemp = zdu(ji,jj) 
     1626           zdu(ji,jj) = zdu(ji,jj) * zcos_w(ji,jj) + zdv(ji,jj) * zsin_w(ji,jj) 
     1627           zdv(ji,jj) = zdv(ji,jj) * zsin_w(ji,jj) - ztemp * zsin_w(ji,jj) 
     1628        END_2D 
     1629    END SUBROUTINE zdf_osm_velocity_rotation 
     1630 
     1631    SUBROUTINE zdf_osm_osbl_state_fk( lpyc, lflux, lmle, zwb_fk ) 
     1632     !!--------------------------------------------------------------------- 
     1633     !!                   ***  ROUTINE zdf_osm_osbl_state_fk  *** 
     1634     !! 
     1635     !! ** Purpose : Determines the state of the OSBL and MLE layer. Info is returned in the logicals lpyc,lflux and lmle. Used with Fox-Kemper scheme. 
     1636     !!  lpyc :: determines whether pycnocline flux-grad relationship needs to be determined 
     1637     !!  lflux :: determines whether effects of surface flux extend below the base of the OSBL 
     1638     !!  lmle  :: determines whether the layer with MLE is increasing with time or if base is relaxing towards hbl.  
     1639     !! 
     1640     !! ** Method  :  
     1641     !! 
     1642     !!  
     1643     !!---------------------------------------------------------------------- 
     1644       
     1645! Outputs 
     1646      LOGICAL,  DIMENSION(jpi,jpj)  :: lpyc, lflux, lmle 
     1647      REAL(wp), DIMENSION(jpi,jpj)  :: zwb_fk 
     1648! 
     1649      REAL(wp), DIMENSION(jpi,jpj)  :: znd_param 
     1650      REAL(wp)                      :: zbuoy, ztmp, zpe_mle_layer 
     1651      REAL(wp)                      :: zpe_mle_ref, zwb_ent, zdbdz_mle_int 
     1652       
     1653      znd_param(:,:) = 0._wp 
     1654 
     1655        DO_2D( 0, 0, 0, 0 ) 
     1656          ztmp =  r1_ft(ji,jj) *  MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 
     1657          zwb_fk(ji,jj) = rn_osm_mle_ce * hmle(ji,jj) * hmle(ji,jj) * ztmp * zdbds_mle(ji,jj) * zdbds_mle(ji,jj) 
     1658        END_2D 
     1659        DO_2D( 0, 0, 0, 0 ) 
     1660                 ! 
     1661         IF ( lconv(ji,jj) ) THEN 
     1662           IF ( zhmle(ji,jj) > 1.2 * zhbl(ji,jj) ) THEN 
     1663             zt_mle(ji,jj) = ( zt_mle(ji,jj) * zhmle(ji,jj) - zt_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 
     1664             zs_mle(ji,jj) = ( zs_mle(ji,jj) * zhmle(ji,jj) - zs_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 
     1665             zb_mle(ji,jj) = ( zb_mle(ji,jj) * zhmle(ji,jj) - zb_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 
     1666             zdbdz_mle_int = ( zb_bl(ji,jj) - ( 2.0 * zb_mle(ji,jj) -zb_bl(ji,jj) ) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 
     1667! Calculate potential energies of actual profile and reference profile. 
     1668             zpe_mle_layer = 0._wp 
     1669             zpe_mle_ref = 0._wp 
     1670             DO jk = ibld(ji,jj), mld_prof(ji,jj) 
     1671               zbuoy = grav * ( zthermal * ts(ji,jj,jk,jp_tem,Kmm) - zbeta * ts(ji,jj,jk,jp_sal,Kmm) ) 
     1672               zpe_mle_layer = zpe_mle_layer + zbuoy * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     1673               zpe_mle_ref = zpe_mle_ref + ( zb_bl(ji,jj) - zdbdz_mle_int * ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) ) * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     1674             END DO 
     1675! Non-dimensional parameter to diagnose the presence of thermocline 
     1676                 
     1677             znd_param(ji,jj) = ( zpe_mle_layer - zpe_mle_ref ) * ABS( ff_t(ji,jj) ) / ( MAX( zwb_fk(ji,jj), 1.0e-10 ) * zhmle(ji,jj) ) 
     1678           ENDIF 
     1679         ENDIF 
     1680        END_2D 
     1681 
     1682! Diagnosis 
     1683        DO_2D( 0, 0, 0, 0 ) 
     1684          IF ( lconv(ji,jj) ) THEN 
     1685            zwb_ent = - 2.0 * 0.2 * zwbav(ji,jj) & 
     1686               &                  - 0.15 * zustar(ji,jj)**3 /zhml(ji,jj) & 
     1687               &         + ( 0.15 * EXP( -1.5 * zla(ji,jj) ) * zustar(ji,jj)**3 & 
     1688               &         - 0.03 * zwstrl(ji,jj)**3 ) / zhml(ji,jj) 
     1689            IF ( -2.0 * zwb_fk(ji,jj) / zwb_ent > 0.5 ) THEN 
     1690              IF ( zhmle(ji,jj) > 1.2 * zhbl(ji,jj) ) THEN 
     1691! MLE layer growing 
     1692                IF ( znd_param (ji,jj) > 100. ) THEN 
     1693! Thermocline present 
     1694                  lflux(ji,jj) = .FALSE. 
     1695                  lmle(ji,jj) =.FALSE. 
     1696                ELSE 
     1697! Thermocline not present 
     1698                  lflux(ji,jj) = .TRUE. 
     1699                  lmle(ji,jj) = .TRUE. 
     1700                ENDIF  ! znd_param > 100 
     1701! 
     1702                IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) THEN 
     1703                  lpyc(ji,jj) = .FALSE. 
     1704                ELSE 
     1705                   lpyc = .TRUE. 
     1706                ENDIF 
     1707              ELSE 
     1708! MLE layer restricted to OSBL or just below. 
     1709                IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) THEN 
     1710! Weak stratification MLE layer can grow. 
     1711                  lpyc(ji,jj) = .FALSE. 
     1712                  lflux(ji,jj) = .TRUE. 
     1713                  lmle(ji,jj) = .TRUE. 
     1714                ELSE 
     1715! Strong stratification 
     1716                  lpyc(ji,jj) = .TRUE. 
     1717                  lflux(ji,jj) = .FALSE. 
     1718                  lmle(ji,jj) = .FALSE. 
     1719                ENDIF ! zdb_bl < rn_mle_thresh_bl and  
     1720              ENDIF  ! zhmle > 1.2 zhbl 
     1721            ELSE 
     1722              lpyc(ji,jj) = .TRUE. 
     1723              lflux(ji,jj) = .FALSE. 
     1724              lmle(ji,jj) = .FALSE. 
     1725              IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) lpyc(ji,jj) = .FALSE. 
     1726            ENDIF !  -2.0 * zwb_fk(ji,jj) / zwb_ent > 0.5  
     1727          ELSE 
     1728! Stable Boundary Layer 
     1729            lpyc(ji,jj) = .FALSE. 
     1730            lflux(ji,jj) = .FALSE. 
     1731            lmle(ji,jj) = .FALSE. 
     1732          ENDIF  ! lconv 
     1733        END_2D 
     1734    END SUBROUTINE zdf_osm_osbl_state_fk 
     1735 
     1736    SUBROUTINE zdf_osm_external_gradients(jbase, zdtdz, zdsdz, zdbdz ) 
     1737     !!--------------------------------------------------------------------- 
     1738     !!                   ***  ROUTINE zdf_osm_external_gradients  *** 
     1739     !! 
     1740     !! ** Purpose : Calculates the gradients below the OSBL 
     1741     !! 
     1742     !! ** Method  : Uses ibld and ibld_ext to determine levels to calculate the gradient. 
     1743     !! 
     1744     !!---------------------------------------------------------------------- 
     1745 
     1746     INTEGER, DIMENSION(jpi,jpj)  :: jbase 
     1747     REAL(wp), DIMENSION(jpi,jpj) :: zdtdz, zdsdz, zdbdz   ! External gradients of temperature, salinity and buoyancy. 
     1748 
     1749     INTEGER :: jj, ji, jkb, jkb1 
     1750     REAL(wp) :: zthermal, zbeta 
     1751 
     1752 
     1753     DO_2D( 0, 0, 0, 0 ) 
     1754        IF ( jbase(ji,jj)+1 < mbkt(ji,jj) ) THEN 
     1755           zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 
     1756           zbeta    = rab_n(ji,jj,1,jp_sal) 
     1757           jkb = jbase(ji,jj) 
     1758           jkb1 = MIN(jkb + 1, mbkt(ji,jj)) 
     1759           zdtdz(ji,jj) = - ( ts(ji,jj,jkb1,jp_tem,Kmm) - ts(ji,jj,jkb,jp_tem,Kmm ) ) & 
     1760                &   / e3t(ji,jj,ibld(ji,jj),Kmm) 
     1761           zdsdz(ji,jj) = - ( ts(ji,jj,jkb1,jp_sal,Kmm) - ts(ji,jj,jkb,jp_sal,Kmm ) ) & 
     1762                &   / e3t(ji,jj,ibld(ji,jj),Kmm) 
     1763           zdbdz(ji,jj) = grav * zthermal * zdtdz(ji,jj) - grav * zbeta * zdsdz(ji,jj) 
     1764        ELSE 
     1765           zdtdz(ji,jj) = 0._wp 
     1766           zdsdz(ji,jj) = 0._wp 
     1767           zdbdz(ji,jj) = 0._wp 
     1768        END IF 
     1769     END_2D 
     1770    END SUBROUTINE zdf_osm_external_gradients 
     1771 
     1772    SUBROUTINE zdf_osm_pycnocline_scalar_profiles( zdtdz, zdsdz, zdbdz, zalpha ) 
     1773 
     1774     REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz, zdsdz, zdbdz      ! gradients in the pycnocline 
     1775     REAL(wp), DIMENSION(jpi,jpj) :: zalpha 
     1776 
     1777     INTEGER :: jk, jj, ji 
     1778     REAL(wp) :: ztgrad, zsgrad, zbgrad 
     1779     REAL(wp) :: zgamma_b_nd, znd 
     1780     REAL(wp) :: zzeta_m, zzeta_en, zbuoy_pyc_sc 
     1781     REAL(wp), PARAMETER :: zgamma_b = 2.25, zzeta_sh = 0.15 
     1782 
     1783     DO_2D( 0, 0, 0, 0 ) 
     1784        IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 
     1785           IF ( lconv(ji,jj) ) THEN  ! convective conditions 
     1786             IF ( lpyc(ji,jj) ) THEN 
     1787                zzeta_m = 0.1 + 0.3 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) ) 
     1788                zalpha(ji,jj) = 2.0 * ( 1.0 - ( 0.80 * zzeta_m + 0.5 * SQRT( 3.14159 / zgamma_b ) ) * zdbdz_bl_ext(ji,jj) * zdh(ji,jj) / zdb_ml(ji,jj) ) / ( 0.723 + SQRT( 3.14159 / zgamma_b ) ) 
     1789                zalpha(ji,jj) = MAX( zalpha(ji,jj), 0._wp ) 
     1790 
     1791                ztmp = 1._wp/MAX(zdh(ji,jj), epsln) 
     1792!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1793! Commented lines in this section are not needed in new code, once tested ! 
     1794! can be removed                                                          ! 
     1795!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1796!                   ztgrad = zalpha * zdt_ml(ji,jj) * ztmp + zdtdz_bl_ext(ji,jj) 
     1797!                   zsgrad = zalpha * zds_ml(ji,jj) * ztmp + zdsdz_bl_ext(ji,jj) 
     1798                zbgrad = zalpha(ji,jj) * zdb_ml(ji,jj) * ztmp + zdbdz_bl_ext(ji,jj) 
     1799                zgamma_b_nd = zdbdz_bl_ext(ji,jj) * zdh(ji,jj) / MAX(zdb_ml(ji,jj), epsln) 
     1800                DO jk = 2, ibld(ji,jj)+ibld_ext 
     1801                  znd = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) * ztmp 
     1802                  IF ( znd <= zzeta_m ) THEN 
     1803!                        zdtdz(ji,jj,jk) = zdtdz_bl_ext(ji,jj) + zalpha * zdt_ml(ji,jj) * ztmp * & 
     1804!                &        EXP( -6.0 * ( znd -zzeta_m )**2 ) 
     1805!                        zdsdz(ji,jj,jk) = zdsdz_bl_ext(ji,jj) + zalpha * zds_ml(ji,jj) * ztmp * & 
     1806!                                  & EXP( -6.0 * ( znd -zzeta_m )**2 ) 
     1807                     zdbdz(ji,jj,jk) = zdbdz_bl_ext(ji,jj) + zalpha(ji,jj) * zdb_ml(ji,jj) * ztmp * & 
     1808                               & EXP( -6.0 * ( znd -zzeta_m )**2 ) 
     1809                  ELSE 
     1810!                         zdtdz(ji,jj,jk) =  ztgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 
     1811!                         zdsdz(ji,jj,jk) =  zsgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 
     1812                      zdbdz(ji,jj,jk) =  zbgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 
     1813                  ENDIF 
     1814               END DO 
     1815            ENDIF ! if no pycnocline pycnocline gradients set to zero 
     1816           ELSE 
     1817              ! stable conditions 
     1818              ! if pycnocline profile only defined when depth steady of increasing. 
     1819              IF ( zdhdt(ji,jj) > 0.0 ) THEN        ! Depth increasing, or steady. 
     1820                 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
     1821                    IF ( zhol(ji,jj) >= 0.5 ) THEN      ! Very stable - 'thick' pycnocline 
     1822                       ztmp = 1._wp/MAX(zhbl(ji,jj), epsln) 
     1823                       ztgrad = zdt_bl(ji,jj) * ztmp 
     1824                       zsgrad = zds_bl(ji,jj) * ztmp 
     1825                       zbgrad = zdb_bl(ji,jj) * ztmp 
     1826                       DO jk = 2, ibld(ji,jj) 
     1827                          znd = gdepw(ji,jj,jk,Kmm) * ztmp 
     1828                          zdtdz(ji,jj,jk) =  ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
     1829                          zdbdz(ji,jj,jk) =  zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
     1830                          zdsdz(ji,jj,jk) =  zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 
     1831                       END DO 
     1832                    ELSE                                   ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. 
     1833                       ztmp = 1._wp/MAX(zdh(ji,jj), epsln) 
     1834                       ztgrad = zdt_bl(ji,jj) * ztmp 
     1835                       zsgrad = zds_bl(ji,jj) * ztmp 
     1836                       zbgrad = zdb_bl(ji,jj) * ztmp 
     1837                       DO jk = 2, ibld(ji,jj) 
     1838                          znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) * ztmp 
     1839                          zdtdz(ji,jj,jk) =  ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
     1840                          zdbdz(ji,jj,jk) =  zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
     1841                          zdsdz(ji,jj,jk) =  zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 
     1842                       END DO 
     1843                    ENDIF ! IF (zhol >=0.5) 
     1844                 ENDIF    ! IF (zdb_bl> 0.) 
     1845              ENDIF       ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero and profile arrays are intialized to zero 
     1846           ENDIF          ! IF (lconv) 
     1847        ENDIF      ! IF ( ibld(ji,jj) < mbkt(ji,jj) ) 
     1848     END_2D 
     1849 
     1850    END SUBROUTINE zdf_osm_pycnocline_scalar_profiles 
     1851 
     1852    SUBROUTINE zdf_osm_pycnocline_shear_profiles( zdudz, zdvdz ) 
     1853      !!--------------------------------------------------------------------- 
     1854      !!                   ***  ROUTINE zdf_osm_pycnocline_shear_profiles  *** 
     1855      !! 
     1856      !! ** Purpose : Calculates velocity shear in the pycnocline 
     1857      !! 
     1858      !! ** Method  : 
     1859      !! 
     1860      !!---------------------------------------------------------------------- 
     1861 
     1862      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz, zdvdz 
     1863 
     1864      INTEGER :: jk, jj, ji 
     1865      REAL(wp) :: zugrad, zvgrad, znd 
     1866      REAL(wp) :: zzeta_v = 0.45 
    12901867      ! 
    1291    END SUBROUTINE zdf_osm 
    1292  
    1293  
    1294    SUBROUTINE zdf_osm_init( Kmm )  
     1868      DO_2D( 0, 0, 0, 0 ) 
     1869         ! 
     1870         IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 
     1871            IF ( lconv (ji,jj) ) THEN 
     1872               ! Unstable conditions. Shouldn;t be needed with no pycnocline code. 
     1873!                  zugrad = 0.7 * zdu_ml(ji,jj) / zdh(ji,jj) + 0.3 * zustar(ji,jj)*zustar(ji,jj) / & 
     1874!                       &      ( ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) * & 
     1875!                      &      MIN(zla(ji,jj)**(8.0/3.0) + epsln, 0.12 )) 
     1876               !Alan is this right? 
     1877!                  zvgrad = ( 0.7 * zdv_ml(ji,jj) + & 
     1878!                       &    2.0 * ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) / & 
     1879!                       &          ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird  + epsln ) & 
     1880!                       &      )/ (zdh(ji,jj)  + epsln ) 
     1881!                  DO jk = 2, ibld(ji,jj) - 1 + ibld_ext 
     1882!                     znd = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / (zdh(ji,jj) + epsln ) - zzeta_v 
     1883!                     IF ( znd <= 0.0 ) THEN 
     1884!                        zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( 3.0 * znd ) 
     1885!                        zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( 3.0 * znd ) 
     1886!                     ELSE 
     1887!                        zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( -2.0 * znd ) 
     1888!                        zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( -2.0 * znd ) 
     1889!                     ENDIF 
     1890!                  END DO 
     1891            ELSE 
     1892               ! stable conditions 
     1893               zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj) 
     1894               zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj) 
     1895               DO jk = 2, ibld(ji,jj) 
     1896                  znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 
     1897                  IF ( znd < 1.0 ) THEN 
     1898                     zdudz(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 ) 
     1899                  ELSE 
     1900                     zdudz(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 ) 
     1901                  ENDIF 
     1902                  zdvdz(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 ) 
     1903               END DO 
     1904            ENDIF 
     1905            ! 
     1906         END IF      ! IF ( ibld(ji,jj) + ibld_ext < mbkt(ji,jj) ) 
     1907      END_2D 
     1908    END SUBROUTINE zdf_osm_pycnocline_shear_profiles 
     1909 
     1910   SUBROUTINE zdf_osm_calculate_dhdt( zdhdt, zddhdt ) 
     1911     !!--------------------------------------------------------------------- 
     1912     !!                   ***  ROUTINE zdf_osm_calculate_dhdt  *** 
     1913     !! 
     1914     !! ** Purpose : Calculates the rate at which hbl changes. 
     1915     !! 
     1916     !! ** Method  : 
     1917     !! 
     1918     !!---------------------------------------------------------------------- 
     1919 
     1920    REAL(wp), DIMENSION(jpi,jpj) :: zdhdt, zddhdt        ! Rate of change of hbl 
     1921 
     1922    INTEGER :: jj, ji 
     1923    REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi 
     1924    REAL(wp) :: zvel_max!, zwb_min 
     1925    REAL(wp) :: zzeta_m = 0.3 
     1926    REAL(wp) :: zgamma_c = 2.0 
     1927    REAL(wp) :: zdhoh = 0.1 
     1928    REAL(wp) :: alpha_bc = 0.5 
     1929    REAL, PARAMETER :: a_ddh = 2.5, a_ddh_2 = 3.5 ! also in pycnocline_depth 
     1930  
     1931  DO_2D( 0, 0, 0, 0 ) 
     1932     
     1933    IF ( lshear(ji,jj) ) THEN 
     1934       IF ( lconv(ji,jj) ) THEN    ! Convective 
     1935 
     1936          IF ( ln_osm_mle ) THEN 
     1937 
     1938             IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN 
     1939       ! Fox-Kemper buoyancy flux average over OSBL 
     1940                zwb_fk_b(ji,jj) = zwb_fk(ji,jj) *  & 
     1941                     (1.0 + hmle(ji,jj) / ( 6.0 * hbl(ji,jj) ) * (-1.0 + ( 1.0 - 2.0 * hbl(ji,jj) / hmle(ji,jj))**3) ) 
     1942             ELSE 
     1943                zwb_fk_b(ji,jj) = 0.5 * zwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) 
     1944             ENDIF 
     1945             zvel_max = ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 
     1946             IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0.0 ) THEN 
     1947                ! OSBL is deepening, entrainment > restratification 
     1948                IF ( zdb_bl(ji,jj) > 0.0 .and. zdbdz_bl_ext(ji,jj) > 0.0 ) THEN 
     1949! *** Used for shear Needs to be changed to work stabily 
     1950!                zgamma_b_nd = zdbdz_bl_ext * dh / zdb_ml 
     1951!                zalpha_b = 6.7 * zgamma_b_nd / ( 1.0 + zgamma_b_nd ) 
     1952!                zgamma_b = zgamma_b_nd / ( 0.12 * ( 1.25 + zgamma_b_nd ) ) 
     1953!                za_1 = 1.0 / zgamma_b**2 - 0.017 
     1954!                za_2 = 1.0 / zgamma_b**3 - 0.0025 
     1955!                zpsi = zalpha_b * ( 1.0 + zgamma_b_nd ) * ( za_1 - 2.0 * za_2 * dh / hbl ) 
     1956                   zpsi = 0._wp 
     1957                   zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 
     1958                   zdhdt(ji,jj) = zdhdt(ji,jj)! - zpsi * ( -1.0 / zhml(ji,jj) + 2.4 * zdbdz_bl_ext(ji,jj) / zdb_ml(ji,jj) ) * zwb_min(ji,jj) * zdh(ji,jj) / zdb_bl(ji,jj) 
     1959                   IF ( j_ddh(ji,jj) == 1 ) THEN 
     1960                     IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN 
     1961                        zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     1962                     ELSE 
     1963                        zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     1964                     ENDIF 
     1965! Relaxation to dh_ref = zari * hbl 
     1966                     zddhdt(ji,jj) = -a_ddh_2 * ( 1.0 - zdh(ji,jj) / ( zari * zhbl(ji,jj) ) ) * zwb_ent(ji,jj) / zdb_bl(ji,jj) 
     1967                      
     1968                   ELSE  ! j_ddh == 0 
     1969! Growing shear layer 
     1970                     zddhdt(ji,jj) = -a_ddh * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zwb_ent(ji,jj) / zdb_bl(ji,jj) 
     1971                   ENDIF ! j_ddh 
     1972                     zdhdt(ji,jj) = zdhdt(ji,jj) ! + zpsi * zddhdt(ji,jj) 
     1973                ELSE    ! zdb_bl >0 
     1974                   zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) /  MAX( zvel_max, 1.0e-15) 
     1975                ENDIF 
     1976             ELSE   ! zwb_min + 2*zwb_fk_b < 0 
     1977                ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) 
     1978                zdhdt(ji,jj) = - zvel_mle(ji,jj) 
     1979 
     1980 
     1981             ENDIF 
     1982 
     1983          ELSE 
     1984             ! Fox-Kemper not used. 
     1985 
     1986               zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) * zwb_ent(ji,jj) / & 
     1987               &        MAX((zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird, epsln) 
     1988               zdhdt(ji,jj) = -zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 
     1989             ! added ajgn 23 July as temporay fix 
     1990 
     1991          ENDIF  ! ln_osm_mle 
     1992 
     1993         ELSE    ! lconv - Stable 
     1994             zdhdt(ji,jj) = ( 0.06 + 0.52 * zhol(ji,jj) / 2.0 ) * zvstr(ji,jj)**3 / hbl(ji,jj) + zwbav(ji,jj) 
     1995             IF ( zdhdt(ji,jj) < 0._wp ) THEN 
     1996                ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 
     1997                 zpert = 2.0 * ( 1.0 + 0.0 * 2.0 * zvstr(ji,jj) * rn_Dt / hbl(ji,jj) ) * zvstr(ji,jj)**2 / hbl(ji,jj) 
     1998             ELSE 
     1999                 zpert = MAX( 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj), zdb_bl(ji,jj) ) 
     2000             ENDIF 
     2001             zdhdt(ji,jj) = 2.0 * zdhdt(ji,jj) / MAX(zpert, epsln) 
     2002         ENDIF  ! lconv 
     2003    ELSE ! lshear 
     2004      IF ( lconv(ji,jj) ) THEN    ! Convective 
     2005 
     2006          IF ( ln_osm_mle ) THEN 
     2007 
     2008             IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN 
     2009       ! Fox-Kemper buoyancy flux average over OSBL 
     2010                zwb_fk_b(ji,jj) = zwb_fk(ji,jj) *  & 
     2011                     (1.0 + hmle(ji,jj) / ( 6.0 * hbl(ji,jj) ) * (-1.0 + ( 1.0 - 2.0 * hbl(ji,jj) / hmle(ji,jj))**3) ) 
     2012             ELSE 
     2013                zwb_fk_b(ji,jj) = 0.5 * zwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) 
     2014             ENDIF 
     2015             zvel_max = ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 
     2016             IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0.0 ) THEN 
     2017                ! OSBL is deepening, entrainment > restratification 
     2018                IF ( zdb_bl(ji,jj) > 0.0 .and. zdbdz_bl_ext(ji,jj) > 0.0 ) THEN 
     2019                   zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 
     2020                ELSE 
     2021                   zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) /  MAX( zvel_max, 1.0e-15) 
     2022                ENDIF 
     2023             ELSE 
     2024                ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) 
     2025                zdhdt(ji,jj) = - zvel_mle(ji,jj) 
     2026 
     2027 
     2028             ENDIF 
     2029 
     2030          ELSE 
     2031             ! Fox-Kemper not used. 
     2032 
     2033               zvel_max = -zwb_ent(ji,jj) / & 
     2034               &        MAX((zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird, epsln) 
     2035               zdhdt(ji,jj) = -zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 
     2036             ! added ajgn 23 July as temporay fix 
     2037 
     2038          ENDIF  ! ln_osm_mle 
     2039 
     2040         ELSE                        ! Stable 
     2041             zdhdt(ji,jj) = ( 0.06 + 0.52 * zhol(ji,jj) / 2.0 ) * zvstr(ji,jj)**3 / hbl(ji,jj) + zwbav(ji,jj) 
     2042             IF ( zdhdt(ji,jj) < 0._wp ) THEN 
     2043                ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 
     2044                 zpert = 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj) 
     2045             ELSE 
     2046                 zpert = MAX( 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj), zdb_bl(ji,jj) ) 
     2047             ENDIF 
     2048             zdhdt(ji,jj) = 2.0 * zdhdt(ji,jj) / MAX(zpert, epsln) 
     2049         ENDIF  ! lconv 
     2050      ENDIF ! lshear 
     2051  END_2D 
     2052    END SUBROUTINE zdf_osm_calculate_dhdt 
     2053 
     2054    SUBROUTINE zdf_osm_timestep_hbl( zdhdt ) 
     2055     !!--------------------------------------------------------------------- 
     2056     !!                   ***  ROUTINE zdf_osm_timestep_hbl  *** 
     2057     !! 
     2058     !! ** Purpose : Increments hbl. 
     2059     !! 
     2060     !! ** Method  : If thechange in hbl exceeds one model level the change is 
     2061     !!              is calculated by moving down the grid, changing the buoyancy 
     2062     !!              jump. This is to ensure that the change in hbl does not 
     2063     !!              overshoot a stable layer. 
     2064     !! 
     2065     !!---------------------------------------------------------------------- 
     2066 
     2067 
     2068    REAL(wp), DIMENSION(jpi,jpj) :: zdhdt   ! rates of change of hbl. 
     2069 
     2070    INTEGER :: jk, jj, ji, jm 
     2071    REAL(wp) :: zhbl_s, zvel_max, zdb 
     2072    REAL(wp) :: zthermal, zbeta 
     2073 
     2074     DO_2D( 0, 0, 0, 0 ) 
     2075        IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN 
     2076! 
     2077! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. 
     2078! 
     2079           zhbl_s = hbl(ji,jj) 
     2080           jm = imld(ji,jj) 
     2081           zthermal = rab_n(ji,jj,1,jp_tem) 
     2082           zbeta = rab_n(ji,jj,1,jp_sal) 
     2083 
     2084 
     2085           IF ( lconv(ji,jj) ) THEN 
     2086!unstable 
     2087 
     2088              IF( ln_osm_mle ) THEN 
     2089                 zvel_max = ( zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 
     2090              ELSE 
     2091 
     2092                 zvel_max = -( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) * zwb_ent(ji,jj) / & 
     2093                   &      ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 
     2094 
     2095              ENDIF 
     2096 
     2097              DO jk = imld(ji,jj), ibld(ji,jj) 
     2098                 zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) & 
     2099                      & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), & 
     2100                      &  0.0 ) + zvel_max 
     2101 
     2102 
     2103                 IF ( ln_osm_mle ) THEN 
     2104                    zhbl_s = zhbl_s + MIN( & 
     2105                     & rn_Dt * ( ( -zwb_ent(ji,jj) - 2.0 * zwb_fk_b(ji,jj) )/ zdb ) / FLOAT(ibld(ji,jj) - imld(ji,jj) ), & 
     2106                     & e3w(ji,jj,jm,Kmm) ) 
     2107                 ELSE 
     2108                   zhbl_s = zhbl_s + MIN( & 
     2109                     & rn_Dt * (  -zwb_ent(ji,jj) / zdb ) / FLOAT(ibld(ji,jj) - imld(ji,jj) ), & 
     2110                     & e3w(ji,jj,jm,Kmm) ) 
     2111                 ENDIF 
     2112 
     2113!                    zhbl_s = MIN(zhbl_s,  gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 
     2114                 IF ( zhbl_s >= gdepw(ji,jj,mbkt(ji,jj) + 1,Kmm) ) THEN 
     2115                   zhbl_s = MIN(zhbl_s,  gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 
     2116                   lpyc(ji,jj) = .FALSE. 
     2117                 ENDIF 
     2118                 IF ( zhbl_s >= gdepw(ji,jj,jm+1,Kmm) ) jm = jm + 1 
     2119              END DO 
     2120              hbl(ji,jj) = zhbl_s 
     2121              ibld(ji,jj) = jm 
     2122          ELSE 
     2123! stable 
     2124              DO jk = imld(ji,jj), ibld(ji,jj) 
     2125                 zdb = MAX( & 
     2126                      & grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) )& 
     2127                      &           - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ),& 
     2128                      & 0.0 ) + & 
     2129          &       2.0 * zvstr(ji,jj)**2 / zhbl_s 
     2130 
     2131                 ! Alan is thuis right? I have simply changed hbli to hbl 
     2132                 zhol(ji,jj) = -zhbl_s / ( ( zvstr(ji,jj)**3 + epsln )/ zwbav(ji,jj) ) 
     2133                 zdhdt(ji,jj) = -( zwbav(ji,jj) - 0.04 / 2.0 * zwstrl(ji,jj)**3 / zhbl_s - 0.15 / 2.0 * ( 1.0 - EXP( -1.5 * zla(ji,jj) ) ) * & 
     2134            &                  zustar(ji,jj)**3 / zhbl_s ) * ( 0.725 + 0.225 * EXP( -7.5 * zhol(ji,jj) ) ) 
     2135                 zdhdt(ji,jj) = zdhdt(ji,jj) + zwbav(ji,jj) 
     2136                 zhbl_s = zhbl_s + MIN( zdhdt(ji,jj) / zdb * rn_Dt / FLOAT( ibld(ji,jj) - imld(ji,jj) ), e3w(ji,jj,jm,Kmm) ) 
     2137 
     2138!                    zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 
     2139                 IF ( zhbl_s >= mbkt(ji,jj) + 1 ) THEN 
     2140                   zhbl_s = MIN(zhbl_s,  gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 
     2141                   lpyc(ji,jj) = .FALSE. 
     2142                 ENDIF 
     2143                 IF ( zhbl_s >= gdepw(ji,jj,jm,Kmm) ) jm = jm + 1 
     2144              END DO 
     2145          ENDIF   ! IF ( lconv ) 
     2146          hbl(ji,jj) = MAX(zhbl_s, gdepw(ji,jj,4,Kmm) ) 
     2147          ibld(ji,jj) = MAX(jm, 4 ) 
     2148        ELSE 
     2149! change zero or one model level. 
     2150          hbl(ji,jj) = MAX(zhbl_t(ji,jj), gdepw(ji,jj,4,Kmm) ) 
     2151        ENDIF 
     2152        zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 
     2153     END_2D 
     2154 
     2155    END SUBROUTINE zdf_osm_timestep_hbl 
     2156 
     2157    SUBROUTINE zdf_osm_pycnocline_thickness( dh, zdh ) 
     2158      !!--------------------------------------------------------------------- 
     2159      !!                   ***  ROUTINE zdf_osm_pycnocline_thickness  *** 
     2160      !! 
     2161      !! ** Purpose : Calculates thickness of the pycnocline 
     2162      !! 
     2163      !! ** Method  : The thickness is calculated from a prognostic equation 
     2164      !!              that relaxes the pycnocine thickness to a diagnostic 
     2165      !!              value. The time change is calculated assuming the 
     2166      !!              thickness relaxes exponentially. This is done to deal 
     2167      !!              with large timesteps. 
     2168      !! 
     2169      !!---------------------------------------------------------------------- 
     2170 
     2171      REAL(wp), DIMENSION(jpi,jpj) :: dh, zdh     ! pycnocline thickness. 
     2172       ! 
     2173      INTEGER :: jj, ji 
     2174      INTEGER :: inhml 
     2175      REAL(wp) :: zari, ztau, zdh_ref 
     2176      REAL, PARAMETER :: a_ddh_2 = 3.5 ! also in pycnocline_depth 
     2177 
     2178    DO_2D( 0, 0, 0, 0 ) 
     2179 
     2180      IF ( lshear(ji,jj) ) THEN 
     2181         IF ( lconv(ji,jj) ) THEN 
     2182           IF ( j_ddh(ji,jj) == 0 ) THEN 
     2183! ddhdt for pycnocline determined in osm_calculate_dhdt 
     2184             dh(ji,jj) = dh(ji,jj) + zddhdt(ji,jj) * rn_Dt 
     2185           ELSE 
     2186! Temporary (probably) Recalculate dh_ref to ensure dh doesn't go negative. Can't do this using zddhdt from calculate_dhdt  
     2187             IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN 
     2188               zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2189             ELSE 
     2190               zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2191             ENDIF 
     2192             ztau = MAX( zdb_bl(ji,jj) * ( zari * hbl(ji,jj) ) / ( a_ddh_2 * MAX(-zwb_ent(ji,jj), 1.e-12) ), 2.0 * rn_Dt ) 
     2193             dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau ) + zari * zhbl(ji,jj) * ( 1.0 - EXP( -rn_Dt / ztau ) ) 
     2194             IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zari * zhbl(ji,jj) 
     2195           ENDIF 
     2196             
     2197         ELSE ! lconv 
     2198! Initially shear only for entraining OSBL. Stable code will be needed if extended to stable OSBL  
     2199 
     2200            ztau = hbl(ji,jj) / MAX(zvstr(ji,jj), epsln) 
     2201            IF ( zdhdt(ji,jj) >= 0.0 ) THEN    ! probably shouldn't include wm here 
     2202               ! boundary layer deepening 
     2203               IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
     2204                  ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 
     2205                  zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 
     2206                       & /  MAX(zdb_bl(ji,jj) * zhbl(ji,jj), epsln ) + 0.01  , 0.2 ) 
     2207                  zdh_ref = MIN( zari, 0.2 ) * hbl(ji,jj) 
     2208               ELSE 
     2209                  zdh_ref = 0.2 * hbl(ji,jj) 
     2210               ENDIF 
     2211            ELSE     ! IF(dhdt < 0) 
     2212               zdh_ref = 0.2 * hbl(ji,jj) 
     2213            ENDIF    ! IF (dhdt >= 0) 
     2214            dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau )+ zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 
     2215            IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref       ! can be a problem with dh>hbl for rapid collapse 
     2216            ! Alan: this hml is never defined or used -- do we need it? 
     2217         ENDIF 
     2218           
     2219      ELSE   ! lshear   
     2220! for lshear = .FALSE. calculate ddhdt here 
     2221 
     2222          IF ( lconv(ji,jj) ) THEN 
     2223 
     2224            IF( ln_osm_mle ) THEN 
     2225               IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0._wp ) THEN 
     2226                  ! OSBL is deepening. Note wb_fk_b is zero if ln_osm_mle=F 
     2227                  IF ( zdb_bl(ji,jj) > 0._wp .and. zdbdz_bl_ext(ji,jj) > 0._wp)THEN 
     2228                     IF ( ( zwstrc(ji,jj) / MAX(zvstr(ji,jj), epsln) )**3 <= 0.5 ) THEN  ! near neutral stability 
     2229                        zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2230                     ELSE                                                     ! unstable 
     2231                        zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2232                     ENDIF 
     2233                     ztau = 0.2 * hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 
     2234                     zdh_ref = zari * hbl(ji,jj) 
     2235                  ELSE 
     2236                     ztau = 0.2 * hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 
     2237                     zdh_ref = 0.2 * hbl(ji,jj) 
     2238                  ENDIF 
     2239               ELSE 
     2240                  ztau = 0.2 * hbl(ji,jj) /  MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 
     2241                  zdh_ref = 0.2 * hbl(ji,jj) 
     2242               ENDIF 
     2243            ELSE ! ln_osm_mle 
     2244               IF ( zdb_bl(ji,jj) > 0._wp .and. zdbdz_bl_ext(ji,jj) > 0._wp)THEN 
     2245                  IF ( ( zwstrc(ji,jj) / MAX(zvstr(ji,jj), epsln) )**3 <= 0.5 ) THEN  ! near neutral stability 
     2246                     zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2247                  ELSE                                                     ! unstable 
     2248                     zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 
     2249                  ENDIF 
     2250                  ztau = hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 
     2251                  zdh_ref = zari * hbl(ji,jj) 
     2252               ELSE 
     2253                  ztau = hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 
     2254                  zdh_ref = 0.2 * hbl(ji,jj) 
     2255               ENDIF 
     2256 
     2257            END IF  ! ln_osm_mle 
     2258 
     2259            dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau ) + zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 
     2260!               IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref 
     2261            IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref 
     2262            ! Alan: this hml is never defined or used 
     2263         ELSE   ! IF (lconv) 
     2264            ztau = hbl(ji,jj) / MAX(zvstr(ji,jj), epsln) 
     2265            IF ( zdhdt(ji,jj) >= 0.0 ) THEN    ! probably shouldn't include wm here 
     2266               ! boundary layer deepening 
     2267               IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
     2268                  ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 
     2269                  zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 
     2270                       & /  MAX(zdb_bl(ji,jj) * zhbl(ji,jj), epsln ) + 0.01  , 0.2 ) 
     2271                  zdh_ref = MIN( zari, 0.2 ) * hbl(ji,jj) 
     2272               ELSE 
     2273                  zdh_ref = 0.2 * hbl(ji,jj) 
     2274               ENDIF 
     2275            ELSE     ! IF(dhdt < 0) 
     2276               zdh_ref = 0.2 * hbl(ji,jj) 
     2277            ENDIF    ! IF (dhdt >= 0) 
     2278            dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau )+ zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 
     2279            IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref       ! can be a problem with dh>hbl for rapid collapse 
     2280         ENDIF       ! IF (lconv) 
     2281      ENDIF  ! lshear 
     2282  
     2283      hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) 
     2284      inhml = MAX( INT( dh(ji,jj) / MAX(e3t(ji,jj,ibld(ji,jj),Kmm), 1.e-3) ) , 1 ) 
     2285      imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 3) 
     2286      zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
     2287      zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 
     2288    END_2D 
     2289 
     2290    END SUBROUTINE zdf_osm_pycnocline_thickness 
     2291 
     2292 
     2293   SUBROUTINE zdf_osm_zmld_horizontal_gradients( zmld, zdtdx, zdtdy, zdsdx, zdsdy, dbdx_mle, dbdy_mle, zdbds_mle ) 
     2294      !!---------------------------------------------------------------------- 
     2295      !!                  ***  ROUTINE zdf_osm_horizontal_gradients  *** 
     2296      !! 
     2297      !! ** Purpose :   Calculates horizontal gradients of buoyancy for use with Fox-Kemper parametrization. 
     2298      !! 
     2299      !! ** Method  : 
     2300      !! 
     2301      !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 
     2302      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
     2303 
     2304 
     2305      REAL(wp), DIMENSION(jpi,jpj)     :: dbdx_mle, dbdy_mle ! MLE horiz gradients at u & v points 
     2306      REAL(wp), DIMENSION(jpi,jpj)     :: zdbds_mle ! Magnitude of horizontal buoyancy gradient. 
     2307      REAL(wp), DIMENSION(jpi,jpj)     :: zmld ! ==  estimated FK BLD used for MLE horiz gradients  == ! 
     2308      REAL(wp), DIMENSION(jpi,jpj)     :: zdtdx, zdtdy, zdsdx, zdsdy 
     2309 
     2310      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
     2311      INTEGER  ::   ii, ij, ik, ikmax   ! local integers 
     2312      REAL(wp)                         :: zc 
     2313      REAL(wp)                         :: zN2_c           ! local buoyancy difference from 10m value 
     2314      REAL(wp), DIMENSION(jpi,jpj)     :: ztm, zsm, zLf_NH, zLf_MH 
     2315      REAL(wp), DIMENSION(jpi,jpj,jpts):: ztsm_midu, ztsm_midv, zabu, zabv 
     2316      REAL(wp), DIMENSION(jpi,jpj)     :: zmld_midu, zmld_midv 
     2317!!---------------------------------------------------------------------- 
     2318      ! 
     2319      !                                      !==  MLD used for MLE  ==! 
     2320 
     2321      mld_prof(:,:)  = nlb10               ! Initialization to the number of w ocean point 
     2322      zmld(:,:)  = 0._wp               ! here hmlp used as a dummy variable, integrating vertically N^2 
     2323      zN2_c = grav * rn_osm_mle_rho_c * r1_rho0   ! convert density criteria into N^2 criteria 
     2324      DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) 
     2325         ikt = mbkt(ji,jj) 
     2326         zmld(ji,jj) = zmld(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 
     2327         IF( zmld(ji,jj) < zN2_c )   mld_prof(ji,jj) = MIN( jk , ikt ) + 1   ! Mixed layer level 
     2328      END_3D 
     2329      DO_2D( 1, 1, 1, 1 ) 
     2330         mld_prof(ji,jj) = MAX(mld_prof(ji,jj),ibld(ji,jj)) 
     2331         zmld(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) 
     2332      END_2D 
     2333      ! ensure mld_prof .ge. ibld 
     2334      ! 
     2335      ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 )                  ! max level of the computation 
     2336      ! 
     2337      ztm(:,:) = 0._wp 
     2338      zsm(:,:) = 0._wp 
     2339      DO_3D( 1, 1, 1, 1, 1, ikmax ) 
     2340         zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, mld_prof(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
     2341         ztm(ji,jj) = ztm(ji,jj) + zc * ts(ji,jj,jk,jp_tem,Kmm) 
     2342         zsm(ji,jj) = zsm(ji,jj) + zc * ts(ji,jj,jk,jp_sal,Kmm) 
     2343      END_3D 
     2344      ! average temperature and salinity. 
     2345      ztm(:,:) = ztm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 
     2346      zsm(:,:) = zsm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 
     2347      ! calculate horizontal gradients at u & v points 
     2348 
     2349      DO_2D( 0, 0, 1, 0 ) 
     2350         zdtdx(ji,jj) = ( ztm(ji+1,jj) - ztm( ji,jj) )  * umask(ji,jj,1) / e1u(ji,jj) 
     2351         zdsdx(ji,jj) = ( zsm(ji+1,jj) - zsm( ji,jj) )  * umask(ji,jj,1) / e1u(ji,jj) 
     2352         zmld_midu(ji,jj) = 0.25_wp * (zmld(ji+1,jj) + zmld( ji,jj)) 
     2353         ztsm_midu(ji,jj,jp_tem) = 0.5_wp * ( ztm(ji+1,jj) + ztm( ji,jj) ) 
     2354         ztsm_midu(ji,jj,jp_sal) = 0.5_wp * ( zsm(ji+1,jj) + zsm( ji,jj) ) 
     2355      END_2D 
     2356 
     2357      DO_2D( 1, 0, 0, 0 ) 
     2358         zdtdy(ji,jj) = ( ztm(ji,jj+1) - ztm( ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) 
     2359         zdsdy(ji,jj) = ( zsm(ji,jj+1) - zsm( ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) 
     2360         zmld_midv(ji,jj) = 0.25_wp * (zmld(ji,jj+1) + zmld( ji,jj)) 
     2361         ztsm_midv(ji,jj,jp_tem) = 0.5_wp * ( ztm(ji,jj+1) + ztm( ji,jj) ) 
     2362         ztsm_midv(ji,jj,jp_sal) = 0.5_wp * ( zsm(ji,jj+1) + zsm( ji,jj) ) 
     2363      END_2D 
     2364 
     2365      CALL eos_rab(ztsm_midu, zmld_midu, zabu, Kmm) 
     2366      CALL eos_rab(ztsm_midv, zmld_midv, zabv, Kmm) 
     2367 
     2368      DO_2D( 0, 0, 1, 0 ) 
     2369         dbdx_mle(ji,jj) = grav*(zdtdx(ji,jj)*zabu(ji,jj,jp_tem) - zdsdx(ji,jj)*zabu(ji,jj,jp_sal)) 
     2370      END_2D 
     2371      DO_2D( 1, 0, 0, 0 ) 
     2372         dbdy_mle(ji,jj) = grav*(zdtdy(ji,jj)*zabv(ji,jj,jp_tem) - zdsdy(ji,jj)*zabv(ji,jj,jp_sal)) 
     2373      END_2D 
     2374 
     2375      DO_2D( 0, 0, 0, 0 ) 
     2376        ztmp =  r1_ft(ji,jj) *  MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 
     2377        zdbds_mle(ji,jj) = SQRT( 0.5_wp * ( dbdx_mle(ji,jj) * dbdx_mle(ji,jj) + dbdy_mle(ji,jj) * dbdy_mle(ji,jj) & 
     2378             & + dbdx_mle(ji-1,jj) * dbdx_mle(ji-1,jj) + dbdy_mle(ji,jj-1) * dbdy_mle(ji,jj-1) ) ) 
     2379      END_2D 
     2380       
     2381 END SUBROUTINE zdf_osm_zmld_horizontal_gradients 
     2382  SUBROUTINE zdf_osm_mle_parameters( mld_prof, hmle, zhmle, zvel_mle, zdiff_mle ) 
     2383      !!---------------------------------------------------------------------- 
     2384      !!                  ***  ROUTINE zdf_osm_mle_parameters  *** 
     2385      !! 
     2386      !! ** Purpose :   Timesteps the mixed layer eddy depth, hmle and calculates the mixed layer eddy fluxes for buoyancy, heat and salinity. 
     2387      !! 
     2388      !! ** Method  : 
     2389      !! 
     2390      !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 
     2391      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
     2392 
     2393      INTEGER, DIMENSION(jpi,jpj)      :: mld_prof 
     2394      REAL(wp), DIMENSION(jpi,jpj)     :: hmle, zhmle, zwb_fk, zvel_mle, zdiff_mle 
     2395      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
     2396      INTEGER  ::   ii, ij, ik, jkb, jkb1  ! local integers 
     2397      INTEGER , DIMENSION(jpi,jpj)     :: inml_mle 
     2398      REAL(wp) ::  ztmp, zdbdz, zdtdz, zdsdz, zthermal,zbeta, zbuoy, zdb_mle 
     2399 
     2400   ! Calculate vertical buoyancy, heat and salinity fluxes due to MLE. 
     2401 
     2402      DO_2D( 0, 0, 0, 0 ) 
     2403       IF ( lconv(ji,jj) ) THEN 
     2404          ztmp =  r1_ft(ji,jj) *  MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 
     2405   ! This velocity scale, defined in Fox-Kemper et al (2008), is needed for calculating dhdt. 
     2406          zvel_mle(ji,jj) = zdbds_mle(ji,jj) * ztmp * hmle(ji,jj) * tmask(ji,jj,1) 
     2407          zdiff_mle(ji,jj) = 5.e-4_wp * rn_osm_mle_ce * ztmp * zdbds_mle(ji,jj) * zhmle(ji,jj)**2 
     2408       ENDIF 
     2409      END_2D 
     2410   ! Timestep mixed layer eddy depth. 
     2411      DO_2D( 0, 0, 0, 0 ) 
     2412        IF ( lmle(ji,jj) ) THEN  ! MLE layer growing. 
     2413! Buoyancy gradient at base of MLE layer. 
     2414           zthermal = rab_n(ji,jj,1,jp_tem) 
     2415           zbeta    = rab_n(ji,jj,1,jp_sal) 
     2416           jkb = mld_prof(ji,jj) 
     2417           jkb1 = MIN(jkb + 1, mbkt(ji,jj)) 
     2418!               
     2419           zbuoy = grav * ( zthermal * ts(ji,jj,mld_prof(ji,jj)+2,jp_tem,Kmm) - zbeta * ts(ji,jj,mld_prof(ji,jj)+2,jp_sal,Kmm) ) 
     2420           zdb_mle = zb_bl(ji,jj) - zbuoy  
     2421! Timestep hmle.  
     2422           hmle(ji,jj) = hmle(ji,jj) + zwb0(ji,jj) * rn_Dt / zdb_mle 
     2423        ELSE 
     2424           IF ( zhmle(ji,jj) > zhbl(ji,jj) ) THEN 
     2425              hmle(ji,jj) = hmle(ji,jj) - ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau 
     2426           ELSE 
     2427              hmle(ji,jj) = hmle(ji,jj) - 10.0 * ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt /rn_osm_mle_tau 
     2428           ENDIF 
     2429        ENDIF 
     2430        hmle(ji,jj) = MIN(hmle(ji,jj), ht(ji,jj)) 
     2431       IF(ln_osm_hmle_limit) hmle(ji,jj) = MIN(hmle(ji,jj), MAX(rn_osm_hmle_limit,1.2*hbl(ji,jj)) ) 
     2432      END_2D 
     2433 
     2434      mld_prof = 4 
     2435      DO_3D( 0, 0, 0, 0, 5, jpkm1 ) 
     2436      IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN(mbkt(ji,jj), jk) 
     2437      END_3D 
     2438      DO_2D( 0, 0, 0, 0 ) 
     2439         zhmle(ji,jj) = gdepw(ji,jj, mld_prof(ji,jj),Kmm) 
     2440      END_2D 
     2441END SUBROUTINE zdf_osm_mle_parameters 
     2442 
     2443END SUBROUTINE zdf_osm 
     2444 
     2445 
     2446   SUBROUTINE zdf_osm_init( Kmm ) 
    12952447     !!---------------------------------------------------------------------- 
    12962448     !!                  ***  ROUTINE zdf_osm_init  *** 
    … …  
    13042456     !! ** input   :   Namlist namosm 
    13052457     !!---------------------------------------------------------------------- 
    1306      INTEGER, INTENT(in)    :: Kmm ! time level index (middle) 
    1307      ! 
     2458     INTEGER, INTENT(in)   ::   Kmm       ! time level 
    13082459     INTEGER  ::   ios            ! local integer 
    13092460     INTEGER  ::   ji, jj, jk     ! dummy loop indices 
     2461     REAL z1_t2 
    13102462     !! 
    13112463     NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave & 
    1312           & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0 & 
    1313           & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv 
     2464          & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0, rn_zdfosm_adjust_sd & 
     2465          & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv, nn_osm_wave & 
     2466          & ,nn_osm_SD_reduce, ln_osm_mle, rn_osm_hblfrac, rn_osm_bl_thresh, ln_zdfosm_ice_shelter 
     2467! Namelist for Fox-Kemper parametrization. 
     2468      NAMELIST/namosm_mle/ nn_osm_mle, rn_osm_mle_ce, rn_osm_mle_lf, rn_osm_mle_time, rn_osm_mle_lat,& 
     2469           & rn_osm_mle_rho_c, rn_osm_mle_thresh, rn_osm_mle_tau, ln_osm_hmle_limit, rn_osm_hmle_limit 
     2470 
    13142471     !!---------------------------------------------------------------------- 
    13152472     ! 
    … …  
    13252482        WRITE(numout,*) 'zdf_osm_init : OSMOSIS Parameterisation' 
    13262483        WRITE(numout,*) '~~~~~~~~~~~~' 
    1327         WRITE(numout,*) '   Namelist namzdf_osm : set tke mixing parameters' 
    1328         WRITE(numout,*) '     Use namelist  rn_osm_la                     ln_use_osm_la = ', ln_use_osm_la 
     2484        WRITE(numout,*) '   Namelist namzdf_osm : set osm mixing parameters' 
     2485        WRITE(numout,*) '     Use  rn_osm_la                                ln_use_osm_la = ', ln_use_osm_la 
     2486        WRITE(numout,*) '     Use  MLE in OBL, i.e. Fox-Kemper param        ln_osm_mle = ', ln_osm_mle 
    13292487        WRITE(numout,*) '     Turbulent Langmuir number                     rn_osm_la   = ', rn_osm_la 
     2488        WRITE(numout,*) '     Stokes drift reduction factor                 rn_zdfosm_adjust_sd   = ', rn_zdfosm_adjust_sd 
    13302489        WRITE(numout,*) '     Initial hbl for 1D runs                       rn_osm_hbl0   = ', rn_osm_hbl0 
    1331         WRITE(numout,*) '     Depth scale of Stokes drift                rn_osm_dstokes = ', rn_osm_dstokes 
     2490        WRITE(numout,*) '     Depth scale of Stokes drift                   rn_osm_dstokes = ', rn_osm_dstokes 
    13322491        WRITE(numout,*) '     horizontal average flag                       nn_ave      = ', nn_ave 
    13332492        WRITE(numout,*) '     Stokes drift                                  nn_osm_wave = ', nn_osm_wave 
    … …  
    13392498        CASE(2) 
    13402499           WRITE(numout,*) '     calculated from ECMWF wave fields' 
     2500         END SELECT 
     2501        WRITE(numout,*) '     Stokes drift reduction                        nn_osm_SD_reduce', nn_osm_SD_reduce 
     2502        WRITE(numout,*) '     fraction of hbl to average SD over/fit' 
     2503        WRITE(numout,*) '     exponential with nn_osm_SD_reduce = 1 or 2    rn_osm_hblfrac =  ', rn_osm_hblfrac 
     2504        SELECT CASE (nn_osm_SD_reduce) 
     2505        CASE(0) 
     2506           WRITE(numout,*) '     No reduction' 
     2507        CASE(1) 
     2508           WRITE(numout,*) '     Average SD over upper rn_osm_hblfrac of BL' 
     2509        CASE(2) 
     2510           WRITE(numout,*) '     Fit exponential to slope rn_osm_hblfrac of BL' 
    13412511        END SELECT 
     2512        WRITE(numout,*) '     reduce surface SD and depth scale under ice   ln_zdfosm_ice_shelter=', ln_zdfosm_ice_shelter 
    13422513        WRITE(numout,*) '     Output osm diagnostics                       ln_dia_osm  = ',  ln_dia_osm 
     2514        WRITE(numout,*) '         Threshold used to define BL              rn_osm_bl_thresh  = ', rn_osm_bl_thresh, 'm^2/s' 
    13432515        WRITE(numout,*) '     Use KPP-style shear instability mixing       ln_kpprimix = ', ln_kpprimix 
    13442516        WRITE(numout,*) '     local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty 
    … …  
    13592531     IF( zdf_osm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' ) 
    13602532 
    1361      call osm_rst( nit000, Kmm, 'READ' ) !* read or initialize hbl 
     2533 
     2534     IF( ln_osm_mle ) THEN 
     2535! Initialise Fox-Kemper parametrization 
     2536         READ  ( numnam_ref, namosm_mle, IOSTAT = ios, ERR = 903) 
     2537903      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namosm_mle in reference namelist') 
     2538 
     2539         READ  ( numnam_cfg, namosm_mle, IOSTAT = ios, ERR = 904 ) 
     2540904      IF( ios >  0 )   CALL ctl_nam ( ios , 'namosm_mle in configuration namelist') 
     2541         IF(lwm) WRITE ( numond, namosm_mle ) 
     2542 
     2543         IF(lwp) THEN                     ! Namelist print 
     2544            WRITE(numout,*) 
     2545            WRITE(numout,*) 'zdf_osm_init : initialise mixed layer eddy (MLE)' 
     2546            WRITE(numout,*) '~~~~~~~~~~~~~' 
     2547            WRITE(numout,*) '   Namelist namosm_mle : ' 
     2548            WRITE(numout,*) '         MLE type: =0 standard Fox-Kemper ; =1 new formulation        nn_osm_mle    = ', nn_osm_mle 
     2549            WRITE(numout,*) '         magnitude of the MLE (typical value: 0.06 to 0.08)           rn_osm_mle_ce    = ', rn_osm_mle_ce 
     2550            WRITE(numout,*) '         scale of ML front (ML radius of deformation) (nn_osm_mle=0)      rn_osm_mle_lf     = ', rn_osm_mle_lf, 'm' 
     2551            WRITE(numout,*) '         maximum time scale of MLE                    (nn_osm_mle=0)      rn_osm_mle_time   = ', rn_osm_mle_time, 's' 
     2552            WRITE(numout,*) '         reference latitude (degrees) of MLE coef.    (nn_osm_mle=1)      rn_osm_mle_lat    = ', rn_osm_mle_lat, 'deg' 
     2553            WRITE(numout,*) '         Density difference used to define ML for FK              rn_osm_mle_rho_c  = ', rn_osm_mle_rho_c 
     2554            WRITE(numout,*) '         Threshold used to define MLE for FK                      rn_osm_mle_thresh  = ', rn_osm_mle_thresh, 'm^2/s' 
     2555            WRITE(numout,*) '         Timescale for OSM-FK                                         rn_osm_mle_tau  = ', rn_osm_mle_tau, 's' 
     2556            WRITE(numout,*) '         switch to limit hmle                                      ln_osm_hmle_limit  = ', ln_osm_hmle_limit 
     2557            WRITE(numout,*) '         fraction of zmld to limit hmle to if ln_osm_hmle_limit =.T.  rn_osm_hmle_limit = ', rn_osm_hmle_limit 
     2558         ENDIF         ! 
     2559     ENDIF 
     2560      ! 
     2561      IF(lwp) THEN 
     2562         WRITE(numout,*) 
     2563         IF( ln_osm_mle ) THEN 
     2564            WRITE(numout,*) '   ==>>>   Mixed Layer Eddy induced transport added to OSMOSIS BL calculation' 
     2565            IF( nn_osm_mle == 0 )   WRITE(numout,*) '              Fox-Kemper et al 2010 formulation' 
     2566            IF( nn_osm_mle == 1 )   WRITE(numout,*) '              New formulation' 
     2567         ELSE 
     2568            WRITE(numout,*) '   ==>>>   Mixed Layer induced transport NOT added to OSMOSIS BL calculation' 
     2569         ENDIF 
     2570      ENDIF 
     2571      ! 
     2572      IF( ln_osm_mle ) THEN                ! MLE initialisation 
     2573         ! 
     2574         rb_c = grav * rn_osm_mle_rho_c /rho0        ! Mixed Layer buoyancy criteria 
     2575         IF(lwp) WRITE(numout,*) 
     2576         IF(lwp) WRITE(numout,*) '      ML buoyancy criteria = ', rb_c, ' m/s2 ' 
     2577         IF(lwp) WRITE(numout,*) '      associated ML density criteria defined in zdfmxl = ', rn_osm_mle_rho_c, 'kg/m3' 
     2578         ! 
     2579         IF( nn_osm_mle == 0 ) THEN           ! MLE array allocation & initialisation            ! 
     2580! 
     2581         ELSEIF( nn_osm_mle == 1 ) THEN           ! MLE array allocation & initialisation 
     2582            rc_f = rn_osm_mle_ce/ (  5.e3_wp * 2._wp * omega * SIN( rad * rn_osm_mle_lat )  ) 
     2583            ! 
     2584         ENDIF 
     2585         !                                ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_osm_mle case) 
     2586         z1_t2 = 2.e-5 
     2587         DO_2D( 1, 1, 1, 1 ) 
     2588            r1_ft(ji,jj) = MIN(1./( ABS(ff_t(ji,jj)) + epsln ), ABS(ff_t(ji,jj))/z1_t2**2) 
     2589         END_2D 
     2590         ! z1_t2 = 1._wp / ( rn_osm_mle_time * rn_osm_mle_timeji,jj ) 
     2591         ! r1_ft(:,:) = 1._wp / SQRT(  ff_t(:,:) * ff_t(:,:) + z1_t2  ) 
     2592         ! 
     2593      ENDIF 
     2594 
     2595     call osm_rst( nit000, Kmm,  'READ' ) !* read or initialize hbl, dh, hmle 
     2596 
    13622597 
    13632598     IF( ln_zdfddm) THEN 
    … …  
    14542689     CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag 
    14552690 
    1456      INTEGER ::   id1, id2   ! iom enquiry index 
     2691     INTEGER ::   id1, id2, id3   ! iom enquiry index 
    14572692     INTEGER  ::   ji, jj, jk     ! dummy loop indices 
    14582693     INTEGER  ::   iiki, ikt ! local integer 
    … …  
    14602695     REAL(wp) ::   zN2_c           ! local scalar 
    14612696     REAL(wp) ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth 
    1462      INTEGER, DIMENSION(:,:), ALLOCATABLE :: imld_rst ! level of mixed-layer depth (pycnocline top) 
     2697     INTEGER, DIMENSION(jpi,jpj) :: imld_rst ! level of mixed-layer depth (pycnocline top) 
    14632698     !!---------------------------------------------------------------------- 
    14642699     ! 
    … …  
    14702705        IF( id1 > 0 ) THEN                       ! 'wn' exists; read 
    14712706           CALL iom_get( numror, jpdom_auto, 'wn', ww ) 
    1472            WRITE(numout,*) ' ===>>>> :  ww read from restart file' 
     2707           WRITE(numout,*) ' ===>>>> :  wn read from restart file' 
    14732708        ELSE 
    14742709           ww(:,:,:) = 0._wp 
    1475            WRITE(numout,*) ' ===>>>> :  ww not in restart file, set to zero initially' 
     2710           WRITE(numout,*) ' ===>>>> :  wn not in restart file, set to zero initially' 
    14762711        END IF 
     2712 
    14772713        id1 = iom_varid( numror, 'hbl'   , ldstop = .FALSE. ) 
    1478         id2 = iom_varid( numror, 'hbli'   , ldstop = .FALSE. ) 
     2714        id2 = iom_varid( numror, 'dh'   , ldstop = .FALSE. ) 
    14792715        IF( id1 > 0 .AND. id2 > 0) THEN                       ! 'hbl' exists; read and return 
    14802716           CALL iom_get( numror, jpdom_auto, 'hbl' , hbl  ) 
    1481            CALL iom_get( numror, jpdom_auto, 'hbli', hbli  ) 
    1482            WRITE(numout,*) ' ===>>>> :  hbl & hbli read from restart file' 
     2717           CALL iom_get( numror, jpdom_auto, 'dh', dh ) 
     2718           WRITE(numout,*) ' ===>>>> :  hbl & dh read from restart file' 
     2719           IF( ln_osm_mle ) THEN 
     2720              id3 = iom_varid( numror, 'hmle'   , ldstop = .FALSE. ) 
     2721              IF( id3 > 0) THEN 
     2722                 CALL iom_get( numror, jpdom_auto, 'hmle' , hmle ) 
     2723                 WRITE(numout,*) ' ===>>>> :  hmle read from restart file' 
     2724              ELSE 
     2725                 WRITE(numout,*) ' ===>>>> :  hmle not found, set to hbl' 
     2726                 hmle(:,:) = hbl(:,:)            ! Initialise MLE depth. 
     2727              END IF 
     2728           END IF 
    14832729           RETURN 
    1484         ELSE                      ! 'hbl' & 'hbli' not in restart file, recalculate 
     2730        ELSE                      ! 'hbl' & 'dh' not in restart file, recalculate 
    14852731           WRITE(numout,*) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification' 
    14862732        END IF 
    … …  
    14902736     ! If READ/WRITE Flag is 'WRITE', write hbl into the restart file, then return 
    14912737     !!----------------------------------------------------------------------------- 
    1492      IF( TRIM(cdrw) == 'WRITE') THEN     !* Write hbli into the restart file, then return 
    1493         IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN        ! Do only on the last tile 
    1494  
     2738     IF( TRIM(cdrw) == 'WRITE') THEN     !* Write hbl into the restart file, then return 
    14952739        IF(lwp) WRITE(numout,*) '---- osm-rst ----' 
    1496          CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww   ) 
    1497          CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl  ) 
    1498          CALL iom_rstput( kt, nitrst, numrow, 'hbli'   , hbli ) 
     2740         CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww  ) 
     2741         CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl ) 
     2742         CALL iom_rstput( kt, nitrst, numrow, 'dh'     , dh  ) 
     2743         IF( ln_osm_mle ) THEN 
     2744            CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle ) 
     2745         END IF 
    14992746        RETURN 
    15002747     END IF 
    … …  
    15042751     !!----------------------------------------------------------------------------- 
    15052752     IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification' 
    1506      ALLOCATE( imld_rst(jpi,jpj) ) 
    15072753     ! w-level of the mixing and mixed layers 
    15082754     CALL eos_rab( ts(:,:,:,:,Kmm), rab_n, Kmm ) 
    … …  
    15132759     ! 
    15142760     hbl(:,:)  = 0._wp              ! here hbl used as a dummy variable, integrating vertically N^2 
    1515      DO_3D( 1, 1, 1, 1, 1, jpkm1 )  ! Mixed layer level: w-level 
     2761     DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    15162762        ikt = mbkt(ji,jj) 
    15172763        hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 
    … …  
    15202766     ! 
    15212767     DO_2D( 1, 1, 1, 1 ) 
    1522         iiki = imld_rst(ji,jj) 
    1523         hbl (ji,jj) = gdepw(ji,jj,iiki  ,Kmm) * ssmask(ji,jj)    ! Turbocline depth 
     2768        iiki = MAX(4,imld_rst(ji,jj)) 
     2769        hbl (ji,jj) = gdepw(ji,jj,iiki,Kmm  )    ! Turbocline depth 
     2770        dh (ji,jj) = e3t(ji,jj,iiki-1,Kmm  )     ! Turbocline depth 
    15242771     END_2D 
    1525      hbl = MAX(hbl,epsln) 
    1526      hbli(:,:) = hbl(:,:) 
    1527      DEALLOCATE( imld_rst ) 
     2772 
    15282773     WRITE(numout,*) ' ===>>>> : hbl computed from stratification' 
     2774 
     2775     IF( ln_osm_mle ) THEN 
     2776        hmle(:,:) = hbl(:,:)            ! Initialise MLE depth. 
     2777        WRITE(numout,*) ' ===>>>> : hmle set = to hbl' 
     2778     END IF 
     2779 
     2780     ww(:,:,:) = 0._wp 
     2781     WRITE(numout,*) ' ===>>>> :  wn not in restart file, set to zero initially' 
    15292782   END SUBROUTINE osm_rst 
    15302783 
    … …  
    15592812      ENDIF 
    15602813 
    1561       ! add non-local temperature and salinity flux 
    15622814      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    15632815         pts(ji,jj,jk,jp_tem,Krhs) =  pts(ji,jj,jk,jp_tem,Krhs)                      & 
    … …  
    15692821      END_3D 
    15702822 
    1571  
    1572       ! save the non-local tracer flux trends for diagnostic 
     2823      ! save the non-local tracer flux trends for diagnostics 
    15732824      IF( l_trdtra )   THEN 
    15742825         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    15752826         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
    1576 !!bug gm jpttdzdf ==> jpttosm 
    1577          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) 
    1578          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_zdf, ztrds ) 
     2827 
     2828         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_osm, ztrdt ) 
     2829         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_osm, ztrds ) 
    15792830         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds ) 
    15802831      ENDIF 
    … …  
    16422893 
    16432894   !!====================================================================== 
     2895 
    16442896END MODULE zdfosm 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfphy.F90

    r14037 r14062  
    179179      IF( ln_zdfmfc .AND. ln_zdfosm )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) 
    180180      IF( lk_top    .AND. ln_zdfnpc )   CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) 
    181       IF( lk_top    .AND. ln_zdfosm )   CALL ctl_stop( 'zdf_phy_init: osmosis scheme is not working with key_top' ) 
     181      IF( lk_top    .AND. ln_zdfosm )   CALL ctl_warn( 'zdf_phy_init: osmosis gives no non-local fluxes for TOP tracers yet' ) 
    182182      IF( lk_top    .AND. ln_zdfmfc )   CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) 
    183183      IF(lwp) THEN 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdftke.F90

    r14037 r14062  
    242242      ! 
    243243      DO_2D( 0, 0, 0, 0 ) 
    244          en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
     244         en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) 
    245245         zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) 
    246246         zd_lw(ji,jj,1) = 1._wp   

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/nemogcm.F90

    r14044 r14062  
    4242   !!---------------------------------------------------------------------- 
    4343   USE step_oce       ! module used in the ocean time stepping module (step.F90) 
     44   ! 
    4445   USE phycst         ! physical constant                  (par_cst routine) 
    4546   USE domain         ! domain initialization   (dom_init & dom_cfg routines) 
    46    USE closea         ! treatment of closed seas (for ln_closea) 
    47    USE usrdef_nam     ! user defined configuration 
    48    USE tide_mod, ONLY : tide_init ! tidal components initialization   (tide_init routine) 
    49    USE bdyini         ! open boundary cond. setting       (bdy_init routine) 
     47   USE wet_dry        ! Wetting and drying setting   (wad_init routine) 
     48   USE usrdef_nam     ! user defined configuration namelist 
     49   USE tide_mod, ONLY : tide_init   ! tidal components initialization   (tide_init routine) 
     50   USE bdyini  , ONLY : bdy_init    ! open boundary cond. setting       (bdy_init routine) 
    5051   USE istate         ! initial state setting          (istate_init routine) 
    51    USE ldfdyn         ! lateral viscosity setting      (ldfdyn_init routine) 
    52    USE ldftra         ! lateral diffusivity setting    (ldftra_init routine) 
    5352   USE trdini         ! dyn/tra trends initialization     (trd_init routine) 
    54    USE asminc         ! assimilation increments      
    55    USE asmbkg         ! writing out state trajectory 
    56    USE diadct         ! sections transports           (dia_dct_init routine) 
    57    USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
    58    USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    59    USE diamlr         ! IOM context management for multiple-linear-regression analysis 
     53   USE icbini         ! handle bergs, initialisation 
     54   USE icbstp  , ONLY : icb_end     ! handle bergs, close iceberg files 
     55   USE cpl_oasis3     ! OASIS3 coupling 
     56   USE dyndmp         ! Momentum damping (C1D only) 
     57   USE step_diu       ! diurnal bulk SST timestepping (called from here if run offline) 
     58   USE crsini         ! initialise grid coarsening utility 
     59   USE dia25h  , ONLY : dia_25h_init   ! 25h mean output (initialisation) 
     60   USE c1d            ! 1D configuration 
     61   USE step_c1d       ! Time stepping loop for the 1D configuration 
     62#if defined key_top 
     63   USE trcini         ! passive tracer initialisation 
     64#endif 
     65#if defined key_nemocice_decomp 
     66   USE ice_domain_size, only: nx_global, ny_global 
     67#endif 
    6068#if defined key_qco 
    61    USE stepMLF        ! NEMO time-stepping               (stp_MLF   routine) 
     69   USE stpmlf         ! NEMO time-stepping               (stp_MLF   routine) 
    6270#else 
    6371   USE step           ! NEMO time-stepping                 (stp     routine) 
    6472#endif 
    65    USE isfstp         ! ice shelf                     (isf_stp_init routine) 
    66    USE icbini         ! handle bergs, initialisation 
    67    USE icbstp         ! handle bergs, calving, themodynamics and transport 
    68    USE cpl_oasis3     ! OASIS3 coupling 
    69    USE c1d            ! 1D configuration 
    70    USE step_c1d       ! Time stepping loop for the 1D configuration 
    71    USE dyndmp         ! Momentum damping 
    72    USE stopar         ! Stochastic param.: ??? 
    73    USE stopts         ! Stochastic param.: ??? 
    74    USE diu_layers     ! diurnal bulk SST and coolskin 
    75    USE step_diu       ! diurnal bulk SST timestepping (called from here if run offline) 
    76    USE crsini         ! initialise grid coarsening utility 
    77    USE dia25h         ! 25h mean output 
    78    USE diadetide      ! Weights computation for daily detiding of model diagnostics 
    79    USE sbc_oce , ONLY : lk_oasis 
    80    USE wet_dry        ! Wetting and drying setting   (wad_init routine) 
    81 #if defined key_top 
    82    USE trcini         ! passive tracer initialisation 
    83 #endif 
    84 #if defined key_nemocice_decomp 
    85    USE ice_domain_size, only: nx_global, ny_global 
    86 #endif 
    8773   ! 
    88    USE prtctl         ! Print control 
    89    USE in_out_manager ! I/O manager 
    9074   USE lib_mpp        ! distributed memory computing 
    9175   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    9276   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges  
    9377   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    94 #if defined key_iomput 
    95    USE xios           ! xIOserver 
    96 #endif 
    97 #if defined key_agrif 
    98    USE agrif_all_update   ! Master Agrif update 
    99 #endif 
    100    USE halo_mng 
     78   USE halo_mng       ! Halo manager 
    10179 
    10280   IMPLICIT NONE 
    … …  
    182160      ! 
    183161      DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    184 #if defined key_qco 
     162#  if defined key_qco 
    185163         CALL stp_MLF 
    186 #else 
     164#  else 
    187165         CALL stp 
    188 #endif 
     166#  endif 
    189167         istp = istp + 1 
    190168      END DO 
    … …  
    195173         ! 
    196174         DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    197  
     175            ! 
    198176            ncom_stp = istp 
    199177            IF( ln_timing ) THEN 
    … …  
    202180               IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
    203181            ENDIF 
    204              
    205 #if defined key_qco 
     182            ! 
     183#  if defined key_qco 
    206184            CALL stp_MLF      ( istp ) 
    207 #else 
     185#  else 
    208186            CALL stp        ( istp )  
    209 #endif 
     187#  endif 
    210188            istp = istp + 1 
    211  
     189            ! 
    212190            IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
    213  
     191            ! 
    214192         END DO 
    215193         ! 
    … …  
    279257      INTEGER ::   ios, ilocal_comm   ! local integers 
    280258      !! 
    281       NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl,                                & 
    282          &             nn_isplt,  nn_jsplt,  nn_ictls, nn_ictle, nn_jctls, nn_jctle             
     259      NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls,   & 
     260         &                                             nn_ictle, nn_jctls , nn_jctle 
    283261      NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 
    284262      !!---------------------------------------------------------------------- 
    … …  
    350328      IF(lwp) THEN                      ! open listing units 
    351329         ! 
    352          IF( .NOT. lwm )   &            ! alreay opened for narea == 1 
     330         IF( .NOT.lwm )   &            ! alreay opened for narea == 1 
    353331            &            CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 
    354332         ! 
    … …  
    357335         WRITE(numout,*) '                       NEMO team' 
    358336         WRITE(numout,*) '            Ocean General Circulation Model' 
    359          WRITE(numout,*) '                NEMO version 4.0  (2019) ' 
     337         WRITE(numout,*) '                NEMO version 4.0  (2020) ' 
    360338         WRITE(numout,*) 
    361339         WRITE(numout,*) "           ._      ._      ._      ._      ._    " 
    … …  
    373351         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    374352         WRITE(numout,*) 
    375           
    376          ! Print the working precision to ocean.output 
    377          IF (wp == dp) THEN 
    378             WRITE(numout,*) "Working precision = double-precision" 
    379          ELSE 
    380             WRITE(numout,*) "Working precision = single-precision" 
     353         ! 
     354         WRITE(numout,cform_aaa)    ! Flag AAAAAAA 
     355         ! 
     356         !                          ! Control print of the working precision 
     357         WRITE(numout,*) 
     358         IF( wp == dp ) THEN   ;   WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" 
     359         ELSE                  ;   WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" 
    381360         ENDIF 
    382          WRITE(numout,*) 
    383          ! 
    384          WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 
     361                                   WRITE(numout,*) "~~~~~~~~                                 ****************" 
     362                                   WRITE(numout,*) 
    385363         ! 
    386364      ENDIF 
    … …  
    415393 
    416394      ! Initialise time level indices 
    417       Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa 
     395      Nbb = 1   ;   Nnn = 2   ;   Naa = 3   ;  Nrhs = Naa 
    418396#if defined key_agrif 
    419       Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
     397      Kbb_a = Nbb   ;   Kmm_a = Nnn   ;  Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    420398#endif  
    421399      !                             !-------------------------------! 
    … …  
    423401      !                             !-------------------------------! 
    424402 
    425       CALL nemo_ctl                          ! Control prints 
     403      CALL nemo_ctl                          ! Control prints of namctl and namcfg 
    426404      ! 
    427405      !                                      ! General initialization 
    … …  
    437415     CALL Agrif_Declare_Var_ini   !  "      "   "   "      "  DOM 
    438416#endif 
    439                            CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    440       IF( ln_crs       )   CALL     crs_init(      Nnn )       ! coarsened grid: domain initialization  
     417                           CALL     dom_init( Nbb, Nnn, Naa )   ! Domain 
     418      IF( ln_crs       )   CALL     crs_init(      Nnn      )   ! coarsened grid: domain initialization  
    441419      IF( sn_cfctl%l_prtctl )   & 
    442420         &                 CALL prt_ctl_init        ! Print control 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/oce.F90

    r13361 r14062  
    1616   PRIVATE 
    1717 
    18    PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 
     18   PUBLIC oce_alloc       ! routine called by nemo_init in     nemogcm.F90 
     19   PUBLIC oce_SWE_alloc   ! routine called by nemo_init in SWE/nemogcm.F90 (Shallow Water Eq. case) 
    1920 
    2021   !! dynamics and tracer fields 
    … …  
    6667   INTEGER, PUBLIC, DIMENSION(2) :: noce_array                             !: unused array but seems to be needed to prevent agrif from creating an empty module 
    6768 
     69   !! Shallow Water Eq. case (SWE) 
     70   LOGICAL, PUBLIC ::   lk_SWE = .FALSE.                                   !: shallow water flag =T in SWE configurations only 
     71 
     72   !! Stand-Alone Surface module (SAS) 
     73   LOGICAL, PUBLIC ::   l_SAS = .FALSE.                                    !: SAS flag =T in SAS configurations only 
     74    
     75    
    6876   !!---------------------------------------------------------------------- 
    6977   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    112120   END FUNCTION oce_alloc 
    113121 
     122 
     123   INTEGER FUNCTION oce_SWE_alloc() 
     124      !!---------------------------------------------------------------------- 
     125      !!                   ***  FUNCTION oce_SWE_alloc  *** 
     126      !!---------------------------------------------------------------------- 
     127      INTEGER :: ierr(2) 
     128      !!---------------------------------------------------------------------- 
     129      ! 
     130      lk_SWE  = .TRUE.                   ! =T SWE case  
     131      ! 
     132      ierr(:) = 0  
     133      ALLOCATE( uu(jpi,jpj,jpk,jpt) , vv  (jpi,jpj,jpk,jpt) ,     &           
     134         &      ww(jpi,jpj,jpk)     , hdiv(jpi,jpj,jpk)     , ssh(jpi,jpj,jpt) , STAT=ierr(1) ) 
     135         ! 
     136      ALLOCATE(   ts(jpi,jpj,jpk,jpts,jpt) , fraqsr_1lev(jpi,jpj) ,  & 
     137         &      uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt)       , rn2(jpi,jpj,jpk) , STAT=ierr(2) ) 
     138         ! 
     139      oce_SWE_alloc = MAXVAL( ierr ) 
     140      IF( oce_SWE_alloc /= 0 )   CALL ctl_stop( 'STOP', 'oce_SWE_alloc: failed to allocate arrays' ) 
     141      ! 
     142   END FUNCTION oce_SWE_alloc 
     143 
    114144   !!====================================================================== 
    115145END MODULE oce 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/step.F90

    r14037 r14062  
    4242   !!---------------------------------------------------------------------- 
    4343   USE step_oce         ! time stepping definition modules 
    44    ! 
    45    USE iom              ! xIOs server 
    4644 
    4745   IMPLICIT NONE 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/step_oce.F90

    r14037 r14062  
    33   !!                       ***  MODULE step_oce  *** 
    44   !! Ocean time-stepping : module used in both initialisation phase and time stepping 
     5   !!                                     (i.e. nemo_init and stp or stp_MLF routines) 
    56   !!====================================================================== 
    67   !! History :   3.3  !  2010-08  (C. Ethe)  Original code - reorganisation of the initial phase 
    … …  
    910   USE oce             ! ocean dynamics and tracers variables 
    1011   USE dom_oce         ! ocean space and time domain variables 
    11    USE domain, ONLY : dom_tile 
    12    USE zdf_oce         ! ocean vertical physics variables 
    13    USE zdfdrg  ,  ONLY : ln_drgimp   ! implicit top/bottom friction 
     12   USE domain  ,  ONLY : dom_tile 
    1413 
    1514   USE daymod          ! calendar                         (day     routine) 
    … …  
    2019   USE sbccpl          ! surface boundary condition: coupled formulation (call send at end of step) 
    2120   USE sbcapr          ! surface boundary condition: atmospheric pressure 
    22    USE tide_mod, ONLY : ln_tide, tide_update 
    2321   USE sbcwave         ! Wave intialisation 
     22   USE tide_mod        ! tides 
     23 
     24   USE bdy_oce  , ONLY : ln_bdy 
     25   USE bdydta          ! open boundary condition data     (bdy_dta routine) 
     26   USE bdytra          ! bdy cond. for tracers            (bdy_tra routine) 
     27   USE bdydyn3d        ! bdy cond. for baroclinic vel.  (bdy_dyn3d routine) 
    2428 
    2529   USE isf_oce         ! ice shelf boundary condition 
    2630   USE isfstp          ! ice shelf boundary condition     (isf_stp routine) 
     31 
     32   USE sshwzv          ! vertical velocity and ssh        (ssh_nxt routine) 
     33   !                                                      (ssh_swp routine) 
     34   !                                                      (wzv     routine) 
     35   USE domvvl          ! variable vertical scale factors  (dom_vvl_sf_nxt routine) 
     36   !                                                      (dom_vvl_sf_swp routine) 
     37    
     38   USE divhor          ! horizontal divergence            (div_hor routine) 
     39   USE dynadv          ! advection                        (dyn_adv routine) 
     40   USE dynvor          ! vorticity term                   (dyn_vor routine) 
     41   USE dynhpg          ! hydrostatic pressure grad.       (dyn_hpg routine) 
     42   USE dynldf          ! lateral momentum diffusion       (dyn_ldf routine) 
     43   USE dynzdf          ! vertical diffusion               (dyn_zdf routine) 
     44   USE dynspg          ! surface pressure gradient        (dyn_spg routine) 
     45   USE dynatf          ! time-filtering                   (dyn_atf routine) 
    2746 
    2847   USE traqsr          ! solar radiation penetration      (tra_qsr routine) 
    … …  
    4059   USE eosbn2          ! equation of state                (eos_bn2 routine) 
    4160 
    42    USE divhor          ! horizontal divergence            (div_hor routine) 
    43    USE dynadv          ! advection                        (dyn_adv routine) 
    44    USE dynvor          ! vorticity term                   (dyn_vor routine) 
    45    USE dynhpg          ! hydrostatic pressure grad.       (dyn_hpg routine) 
    46    USE dynldf          ! lateral momentum diffusion       (dyn_ldf routine) 
    47    USE dynzdf          ! vertical diffusion               (dyn_zdf routine) 
    48    USE dynspg          ! surface pressure gradient        (dyn_spg routine) 
    49  
    50    USE dynatf          ! time-filtering                   (dyn_atf routine) 
    51  
    5261   USE stopar          ! Stochastic parametrization       (sto_par routine) 
    5362   USE stopts  
    54  
    55    USE bdy_oce  , ONLY : ln_bdy 
    56    USE bdydta          ! open boundary condition data     (bdy_dta routine) 
    57    USE bdytra          ! bdy cond. for tracers            (bdy_tra routine) 
    58    USE bdydyn3d        ! bdy cond. for baroclinic vel.  (bdy_dyn3d routine) 
    59  
    60    USE sshwzv          ! vertical velocity and ssh        (ssh_nxt routine) 
    61    !                                                       (ssh_swp routine) 
    62    !                                                       (wzv     routine) 
    63    USE domvvl          ! variable vertical scale factors  (dom_vvl_sf_nxt routine) 
    64    !                                                       (dom_vvl_sf_swp routine) 
    6563 
    6664   USE ldfslp          ! iso-neutral slopes               (ldf_slp routine) 
    … …  
    6866   USE ldftra          ! lateral eddy diffusive coef.     (ldf_tra routine) 
    6967 
     68   USE zdf_oce         ! ocean vertical physics variables 
    7069   USE zdfphy          ! vertical physics manager      (zdf_phy_init routine) 
    71    USE zdfosm  , ONLY : osm_rst, dyn_osm, tra_osm      ! OSMOSIS routines used in step.F90 
     70   USE zdfdrg   , ONLY : ln_drgimp   ! implicit top/bottom friction 
     71   USE zdfosm   , ONLY : osm_rst, dyn_osm, tra_osm      ! OSMOSIS routines used in step.F90 
    7272   USE zdfmfc          ! Mass FLux Convection routine used in step.F90 
    7373 
    … …  
    8383   USE diahth          ! thermocline depth                (dia_hth routine) 
    8484   USE diahsb          ! heat, salt and volume budgets    (dia_hsb routine) 
    85    USE diacfl 
    86    USE diaobs          ! Observation operator 
     85   USE diacfl          ! CFL diagnostics                  (dia_cfl routine) 
     86   USE diaobs          ! Observation operator             (dia_obs routine) 
    8787   USE diadetide       ! Weights computation for daily detiding of model diagnostics 
    8888   USE diamlr          ! IOM context management for multiple-linear-regression analysis 
    … …  
    9494   USE asminc          ! assimilation increments      (tra_asm_inc routine) 
    9595   !                                                   (dyn_asm_inc routine) 
    96    USE asmbkg 
     96   USE asmbkg          ! writing out state trajectory 
    9797   USE stpctl          ! time stepping control            (stp_ctl routine) 
    9898   USE restart         ! ocean restart                    (rst_wri routine) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/stpctl.F90

    r14037 r14062  
    2626   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2727   USE lib_mpp         ! distributed memory computing 
    28    ! 
    2928   USE netcdf          ! NetCDF library 
     29 
    3030   IMPLICIT NONE 
    3131   PRIVATE 
    … …  
    7171      CHARACTER(len=20)               ::   clname 
    7272      !!---------------------------------------------------------------------- 
     73      ! 
    7374      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
    7475      ! 
    … …  
    179180         END DO 
    180181         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    181       END IF 
     182      ENDIF 
    182183      !                                   !==               error handling               ==! 
    183184      !                                   !==  done by all processes at every time step  ==! 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OFF/dtadyn.F90

    r14037 r14062  
    2323   USE c1d             ! 1D configuration: lk_c1d 
    2424   USE dom_oce         ! ocean domain: variables 
    25 #if ! defined key_qco  
    26    USE domvvl          ! variable volume 
     25#if defined key_qco  
     26   USE domqco          ! variable volume 
    2727#else 
    28    USE domqco 
     28   USE domvvl 
    2929#endif 
    3030   USE zdf_oce         ! ocean vertical physics: variables 
    … …  
    9797   !! * Substitutions 
    9898#  include "do_loop_substitute.h90" 
     99#  include "domzgr_substitute.h90" 
     100    
    99101   !!---------------------------------------------------------------------- 
    100102   !! NEMO/OFF 4.0 , NEMO Consortium (2018) 
    … …  
    388390        gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm) 
    389391        ! 
    390       ENDIF 
    391392#endif 
     393      ENDIF 
    392394      ! 
    393395      IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN       ! read depht over which runoffs are distributed 
    … …  
    412414            ENDIF 
    413415         END_2D 
     416         ! 
    414417         DO_2D( 1, 1, 1, 1 )                           ! set the associated depth 
    415418            h_rnf(ji,jj) = 0._wp 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OFF/nemogcm.F90

    r14037 r14062  
    6464   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    6565   USE lbcnfd  , ONLY : isendto, nsndto   ! Setup of north fold exchanges 
    66    USE step, ONLY : Nbb, Nnn, Naa, Nrhs   ! time level indices 
     66#if defined key_qco 
     67   USE stpmlf , ONLY : Nbb, Nnn, Naa, Nrhs   ! time level indices 
     68#else 
     69   USE step    , ONLY : Nbb, Nnn, Naa, Nrhs   ! time level indices 
     70#endif 
    6771   USE halo_mng 
    6872 
    … …  
    143147                                CALL dta_dyn_atf( istp, Nbb, Nnn, Naa )       ! time filter of sea  surface height and vertical scale factors 
    144148# if defined key_qco 
    145                                 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t_f, r3u_f, r3v_f ) 
     149                                CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) 
    146150# endif 
    147151         ENDIF 
    148152                                CALL trc_stp    ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping 
    149153# if defined key_qco 
    150                                 !r3t(:,:,Kmm) = r3t_f(:,:)                     ! update ssh to h0 ratio 
    151                                 !r3u(:,:,Kmm) = r3u_f(:,:) 
    152                                 !r3v(:,:,Kmm) = r3v_f(:,:) 
     154                                !r3t(:,:,Nnn) = r3t_f(:,:)                     ! update ssh to h0 ratio 
     155                                !r3u(:,:,Nnn) = r3u_f(:,:) 
     156                                !r3v(:,:,Nnn) = r3v_f(:,:) 
    153157# endif 
    154158#endif 
    … …  
    160164         ! 
    161165#if ! defined key_qco 
    162 #if ! defined key_sed_off 
     166# if ! defined key_sed_off 
    163167         IF( .NOT.ln_linssh )   CALL dta_dyn_sf_interp( istp, Nnn )  ! calculate now grid parameters 
    164 #endif 
     168# endif 
    165169#endif          
    166170         CALL stp_ctl    ( istp )             ! Time loop: control and print 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SAS/nemogcm.F90

    r14044 r14062  
    216216      !!---------------------------------------------------------------------- 
    217217      ! 
    218       IF( lk_oasis ) THEN   ;   cxios_context = 'sas' 
    219       ELSE                  ;   cxios_context = 'nemo' 
     218      IF( lk_oasis ) THEN   ;   cxios_context = 'sas'    ! when coupling SAS to OCE 
     219      ELSE                  ;   cxios_context = 'nemo'   !  
    220220      ENDIF 
    221221      nn_hls = 1 
     222      ! 
     223      l_SAS = .TRUE.   ! used in domain:dom_nam 
    222224      ! 
    223225      !                             !-------------------------------------------------! 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/domzgr_substitute.h90

    r12983 r14062  
    1616#   define  e3v(i,j,k,t)   (e3v_0(i,j,k)*(1._wp+r3v(i,j,t))) 
    1717#   define  e3f(i,j,k)     (e3f_0(i,j,k)*(1._wp+r3f(i,j))) 
     18#   define  e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j))) 
    1819#   define  e3w(i,j,k,t)   (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 
    1920#   define  e3uw(i,j,k,t)  (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/nemogcm.F90

    r14037 r14062  
    44   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) 
    55   !!====================================================================== 
    6    !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code 
    7    !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec) 
    8    !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 
    9    !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1 
    10    !!             -   ! 1992-06  (L.Terray)  coupling implementation 
    11    !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice 
    12    !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 
    13    !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 
    14    !!            8.1  ! 1997-06  (M. Imbard, G. Madec) 
    15    !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  sea-ice model 
    16    !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP 
    17    !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER) 
    18    !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules 
    19    !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces 
    20    !!             -   ! 2004-08  (C. Talandier) New trends organization 
    21    !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility 
    22    !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization 
    23    !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation 
    24    !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization 
    25    !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY) 
    26    !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp 
    27    !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 
    28    !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
    29    !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
    30    !!             -   ! 2011-11  (C. Harris) decomposition changes for running with CICE 
    31    !!            3.6  ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening  
    32    !!             -   ! 2014-12  (G. Madec) remove KPP scheme and cross-land advection (cla) 
    33    !!            4.0  ! 2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface 
     6   !! History :  4.0  !  2020-05  (A. Nasser, G. Madec)  Original code from 4.0.2 
     7   !!             -   !  2020-10  (S. Techene, G. Madec)  cleanning 
    348   !!---------------------------------------------------------------------- 
    359 
    … …  
    4216   !!---------------------------------------------------------------------- 
    4317   USE step_oce       ! module used in the ocean time stepping module (step.F90) 
     18   ! 
    4419   USE phycst         ! physical constant                  (par_cst routine) 
    4520   USE domain         ! domain initialization   (dom_init & dom_cfg routines) 
    46    USE closea         ! treatment of closed seas (for ln_closea) 
    4721   USE usrdef_nam     ! user defined configuration 
    48    USE tide_mod, ONLY : tide_init ! tidal components initialization   (tide_init routine) 
    49    USE bdy_oce,  ONLY : ln_bdy 
    5022   USE bdyini         ! open boundary cond. setting       (bdy_init routine) 
    5123   USE istate         ! initial state setting          (istate_init routine) 
    52    USE ldfdyn         ! lateral viscosity setting      (ldfdyn_init routine) 
    53    USE ldftra         ! lateral diffusivity setting    (ldftra_init routine) 
    54    USE trdini         ! dyn/tra trends initialization     (trd_init routine) 
    55    USE asminc         ! assimilation increments      
    56    USE asmbkg         ! writing out state trajectory 
    57    USE diaptr         ! poleward transports           (dia_ptr_init routine) 
    58    USE diadct         ! sections transports           (dia_dct_init routine) 
    59    USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
    60    USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    61    USE diamlr         ! IOM context management for multiple-linear-regression analysis 
     24   USE trd_oce , ONLY : l_trddyn         ! dynamical trend logical 
    6225#if defined key_RK3 
    63    USE stpRK3 
    64 #elif defined key_qco 
    65    USE stpLF 
     26   USE stprk3         ! NEMO time-stepping               (stp_RK3   routine) 
    6627#else 
    67    USE step           ! NEMO time-stepping                 (stp     routine) 
    68 #endif 
    69    USE isfstp         ! ice shelf                     (isf_stp_init routine) 
    70    USE icbini         ! handle bergs, initialisation 
    71    USE icbstp         ! handle bergs, calving, themodynamics and transport 
    72    USE cpl_oasis3     ! OASIS3 coupling 
    73    USE c1d            ! 1D configuration 
    74    USE step_c1d       ! Time stepping loop for the 1D configuration 
    75    USE dyndmp         ! Momentum damping 
    76    USE stopar         ! Stochastic param.: ??? 
    77    USE stopts         ! Stochastic param.: ??? 
    78    USE diu_layers     ! diurnal bulk SST and coolskin 
    79    USE crsini         ! initialise grid coarsening utility 
    80    USE dia25h         ! 25h mean output 
    81    USE diadetide      ! Weights computation for daily detiding of model diagnostics 
    82    USE sbc_oce , ONLY : lk_oasis 
    83    USE wet_dry        ! Wetting and drying setting   (wad_init routine) 
    84 #if defined key_top 
    85    USE trcini         ! passive tracer initialisation 
    86 #endif 
    87 #if defined key_nemocice_decomp 
    88    USE ice_domain_size, only: nx_global, ny_global 
     28   USE stpmlf         ! NEMO time-stepping               (stp_MLF   routine) 
    8929#endif 
    9030   ! 
    9131   USE lib_mpp        ! distributed memory computing 
    9232   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    93    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges  
     33   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges  
    9434   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    95 #if defined key_iomput 
    96    USE xios           ! xIOserver 
    97 #endif 
    98 #if defined key_agrif 
    99    USE agrif_all_update   ! Master Agrif update 
    100 #endif 
     35   USE halo_mng       ! Halo manager 
    10136 
    10237   IMPLICIT NONE 
    … …  
    13974      !!---------------------------------------------------------------------- 
    14075      ! 
    141 #if defined key_agrif 
    142       CALL Agrif_Init_Grids()      ! AGRIF: set the meshes 
    143 #endif 
    14476      !                            !-----------------------! 
    14577      CALL nemo_init               !==  Initialisations  ==! 
    14678      !                            !-----------------------! 
    147        
    148 #if defined key_agrif 
    149       Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    150       CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM 
    151       CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA  
    152 # if defined key_top 
    153       CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
    154 # endif 
    155 # if defined key_si3 
    156       CALL Agrif_Declare_Var_ice   !  "      "   "   "      "  Sea ice 
    157 # endif 
    158 #endif 
    15979      ! check that all process are still there... If some process have an error, 
    16080      ! they will never enter in step and other processes will wait until the end of the cpu time! 
     81      ! 
     82      !                                 ! SWE case: only with key_qco 
     83#if ! defined key_qco   
     84      CALL ctl_stop( 'nemo_gcm (SWE): shallow water model requires key_qco' ) 
     85#endif 
     86      ! 
    16187      CALL mpp_max( 'nemogcm', nstop ) 
    16288 
    … …  
    174100      ! 
    175101      DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    176  
     102         ! 
    177103         ncom_stp = istp 
    178104         IF( ln_timing ) THEN 
    … …  
    181107            IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
    182108         ENDIF 
     109         !  
    183110#if defined key_RK3 
    184111         CALL stp_RK3    ( istp ) 
    185 #elif defined key_qco 
    186          CALL stp_LF     ( istp ) 
    187112#else 
    188          CALL stp        ( istp ) 
     113         CALL stp_MLF     ( istp ) 
    189114#endif 
    190115         istp = istp + 1 
    191  
     116         ! 
    192117         IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
    193  
     118         ! 
    194119      END DO 
    195120      ! 
    … …  
    232157      INTEGER ::   ios, ilocal_comm   ! local integers 
    233158      !! 
    234       NAMELIST/namctl/ sn_cfctl,  nn_print, nn_ictls, nn_ictle,             & 
    235          &             nn_isplt , nn_jsplt, nn_jctls, nn_jctle,             & 
    236          &             ln_timing, ln_diacfl 
     159      NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls,   & 
     160         &                                             nn_ictle, nn_jctls , nn_jctle 
    237161      NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 
    238162      !!---------------------------------------------------------------------- 
    … …  
    246170      ! 
    247171#if defined key_iomput 
    248       IF( Agrif_Root() ) THEN 
    249          IF( lk_oasis ) THEN 
    250             CALL cpl_init( "oceanx", ilocal_comm )                               ! nemo local communicator given by oasis 
    251             CALL xios_initialize( "not used"       , local_comm =ilocal_comm )   ! send nemo communicator to xios 
    252          ELSE 
    253             CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )   ! nemo local communicator given by xios 
    254          ENDIF 
    255       ENDIF 
     172      CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )   ! nemo local communicator given by xios 
    256173      CALL mpp_start( ilocal_comm ) 
    257174#else 
    258       IF( lk_oasis ) THEN 
    259          IF( Agrif_Root() ) THEN 
    260             CALL cpl_init( "oceanx", ilocal_comm )          ! nemo local communicator given by oasis 
    261          ENDIF 
    262          CALL mpp_start( ilocal_comm ) 
    263       ELSE 
    264          CALL mpp_start( ) 
    265       ENDIF 
     175      CALL mpp_start( ) 
    266176#endif 
    267177      ! 
    … …  
    292202      ! 
    293203      ! finalize the definition of namctl variables 
    294       IF( sn_cfctl%l_allon ) THEN 
    295          ! Turn on all options. 
    296          CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. ) 
    297          ! Ensure all processors are active 
    298          sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1 
    299       ELSEIF( sn_cfctl%l_config ) THEN 
    300          ! Activate finer control of report outputs 
    301          ! optionally switch off output from selected areas (note this only 
    302          ! applies to output which does not involve global communications) 
    303          IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax  ) .OR. & 
    304            & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) )    & 
    305            &   CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 
    306       ELSE 
    307          ! turn off all options. 
    308          CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. ) 
    309       ENDIF 
     204      IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 )   & 
     205         &   CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) 
    310206      ! 
    311207      lwp = (narea == 1) .OR. sn_cfctl%l_oceout    ! control of all listing output print 
    … …  
    336232         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    337233         WRITE(numout,*) 
     234          
     235         ! Print the working precision to ocean.output 
     236         IF (wp == dp) THEN 
     237            WRITE(numout,*) "Working precision = double-precision" 
     238         ELSE 
     239            WRITE(numout,*) "Working precision = single-precision" 
     240         ENDIF 
     241         WRITE(numout,*) 
    338242         ! 
    339243         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 
    … …  
    353257      ! 
    354258      IF( ln_read_cfg ) THEN            ! Read sizes in domain configuration file 
    355          CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     259         CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 
    356260      ELSE                              ! user-defined namelist 
    357          CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     261         CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 
    358262      ENDIF 
    359263      ! 
    … …  
    365269      CALL mpp_init 
    366270 
     271      CALL halo_mng_init() 
    367272      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    368273      CALL nemo_alloc() 
    369274 
    370275      ! Initialise time level indices 
    371       Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa 
    372  
     276      Nbb = 1   ;   Nnn = 2   ;   Naa = 3   ;  Nrhs = Naa 
     277       
    373278      !                             !-------------------------------! 
    374279      !                             !  NEMO general initialization  ! 
    … …  
    382287      ! 
    383288                           CALL     phy_cst         ! Physical constants 
    384                             
     289      ! 
     290      !                                             ! SWE: Set rho0 and associated variables (eosbn2 not used) 
     291                           rho0        = 1026._wp                 !: volumic mass of reference     [kg/m3] 
     292                           rcp         = 3991.86795711963_wp      !: heat capacity     [J/K] 
     293                           rho0_rcp    = rho0 * rcp  
     294                           r1_rho0     = 1._wp / rho0 
     295                           r1_rcp      = 1._wp / rcp 
     296                           r1_rho0_rcp = 1._wp / rho0_rcp  
     297      ! 
    385298                           CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    386299 
    … …  
    391304 
    392305      !                                      ! external forcing  
    393                            CALL    tide_init                     ! tidal harmonics 
    394  
    395306                           CALL     sbc_init( Nbb, Nnn, Naa )    ! surface boundary conditions (including sea-ice) 
    396                             
    397307 
    398308      !                                      ! Ocean physics                                     
    … …  
    400310                           CALL ldf_dyn_init      ! Lateral ocean momentum physics 
    401311                            
    402                             
    403312      !                                      ! Dynamics 
    404313                           CALL dyn_adv_init         ! advection (vector or flux form) 
    405  
    406314                           CALL dyn_vor_init         ! vorticity term including Coriolis 
    407  
    408315                           CALL dyn_ldf_init         ! lateral mixing 
    409316 
    410                            CALL dyn_spg_init         ! surface pressure gradient 
    411  
    412317      !                                      ! Diagnostics 
    413                            CALL     flo_init( Nnn )    ! drifting Floats 
    414                             
    415318      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics 
    416  
    417                            CALL     trd_init( Nnn )    ! Mixed-layer/Vorticity/Integral constraints trends 
    418  
     319      !                                         ! Trends diag: switched off 
     320                           l_trddyn = .FALSE.        ! No trend diagnostics 
    419321 
    420322      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA 
    … …  
    422324      IF( ln_timing    )   CALL timing_stop( 'nemo_init') 
    423325      ! 
    424  
    425326   END SUBROUTINE nemo_init 
    426327 
    … …  
    440341         WRITE(numout,*) '~~~~~~~~' 
    441342         WRITE(numout,*) '   Namelist namctl' 
    442          WRITE(numout,*) '                              sn_cfctl%l_glochk  = ', sn_cfctl%l_glochk 
    443          WRITE(numout,*) '                              sn_cfctl%l_allon   = ', sn_cfctl%l_allon 
    444          WRITE(numout,*) '       finer control over o/p sn_cfctl%l_config  = ', sn_cfctl%l_config 
    445343         WRITE(numout,*) '                              sn_cfctl%l_runstat = ', sn_cfctl%l_runstat 
    446344         WRITE(numout,*) '                              sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat 
    … …  
    454352         WRITE(numout,*) '                              sn_cfctl%procincr  = ', sn_cfctl%procincr  
    455353         WRITE(numout,*) '                              sn_cfctl%ptimincr  = ', sn_cfctl%ptimincr  
    456          WRITE(numout,*) '      level of print                  nn_print   = ', nn_print 
    457          WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls 
    458          WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle 
    459          WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls 
    460          WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle 
    461          WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt 
    462          WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt 
    463354         WRITE(numout,*) '      timing by routine               ln_timing  = ', ln_timing 
    464355         WRITE(numout,*) '      CFL diagnostics                 ln_diacfl  = ', ln_diacfl 
    465356      ENDIF 
    466357      ! 
    467       nprint    = nn_print          ! convert DOCTOR namelist names into OLD names 
    468       nictls    = nn_ictls 
    469       nictle    = nn_ictle 
    470       njctls    = nn_jctls 
    471       njctle    = nn_jctle 
    472       isplt     = nn_isplt 
    473       jsplt     = nn_jsplt 
    474  
     358      IF( .NOT.ln_read_cfg )   ln_closea = .false.   ! dealing possible only with a domcfg file 
    475359      IF(lwp) THEN                  ! control print 
    476360         WRITE(numout,*) 
    … …  
    482366         WRITE(numout,*) '         filename to be written                        cn_domcfg_out = ', TRIM(cn_domcfg_out) 
    483367         WRITE(numout,*) '      use file attribute if exists as i/p j-start   ln_use_jattr     = ', ln_use_jattr 
    484       ENDIF 
    485       IF( .NOT.ln_read_cfg )   ln_closea = .false.   ! dealing possible only with a domcfg file 
    486       ! 
    487       !                             ! Parameter control 
    488       ! 
    489       IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN              ! sub-domain area indices for the control prints 
    490          IF( lk_mpp .AND. jpnij > 1 ) THEN 
    491             isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain 
    492          ELSE 
    493             IF( isplt == 1 .AND. jsplt == 1  ) THEN 
    494                CALL ctl_warn( ' - isplt & jsplt are equal to 1',   & 
    495                   &           ' - the print control will be done over the whole domain' ) 
    496             ENDIF 
    497             ijsplt = isplt * jsplt            ! total number of processors ijsplt 
    498          ENDIF 
    499          IF(lwp) WRITE(numout,*)'          - The total number of processors over which the' 
    500          IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt 
    501          ! 
    502          !                              ! indices used for the SUM control 
    503          IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area 
    504             lsp_area = .FALSE. 
    505          ELSE                                             ! print control done over a specific  area 
    506             lsp_area = .TRUE. 
    507             IF( nictls < 1 .OR. nictls > jpiglo )   THEN 
    508                CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' ) 
    509                nictls = 1 
    510             ENDIF 
    511             IF( nictle < 1 .OR. nictle > jpiglo )   THEN 
    512                CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' ) 
    513                nictle = jpiglo 
    514             ENDIF 
    515             IF( njctls < 1 .OR. njctls > jpjglo )   THEN 
    516                CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' ) 
    517                njctls = 1 
    518             ENDIF 
    519             IF( njctle < 1 .OR. njctle > jpjglo )   THEN 
    520                CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' ) 
    521                njctle = jpjglo 
    522             ENDIF 
    523          ENDIF 
    524368      ENDIF 
    525369      ! 
    … …  
    571415      USE diawri    , ONLY : dia_wri_alloc 
    572416      USE dom_oce   , ONLY : dom_oce_alloc 
    573       USE trc_oce   , ONLY : trc_oce_alloc 
    574       USE bdy_oce   , ONLY : bdy_oce_alloc 
    575417      ! 
    576418      INTEGER :: ierr 
    577419      !!---------------------------------------------------------------------- 
    578420      ! 
    579       ierr =        oce_alloc    ()    ! ocean  
     421      ierr =        oce_SWE_alloc()    ! ocean  
    580422      ierr = ierr + dia_wri_alloc() 
    581423      ierr = ierr + dom_oce_alloc()    ! ocean domain 
    582424      ierr = ierr + zdf_oce_alloc()    ! ocean vertical physics 
    583       ierr = ierr + trc_oce_alloc()    ! shared TRC / TRA arrays 
    584       ierr = ierr + bdy_oce_alloc()    ! bdy masks (incl. initialization) 
    585425      ! 
    586426      CALL mpp_sum( 'nemogcm', ierr ) 
    … …  
    590430 
    591431    
    592    SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 
     432   SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 
    593433      !!---------------------------------------------------------------------- 
    594434      !!                     ***  ROUTINE nemo_set_cfctl  *** 
    595435      !! 
    596436      !! ** Purpose :   Set elements of the output control structure to setto. 
    597       !!                for_all should be .false. unless all areas are to be 
    598       !!                treated identically. 
    599437      !! 
    600438      !! ** Method  :   Note this routine can be used to switch on/off some 
    601       !!                types of output for selected areas but any output types 
    602       !!                that involve global communications (e.g. mpp_max, glob_sum) 
    603       !!                should be protected from selective switching by the 
    604       !!                for_all argument 
    605       !!---------------------------------------------------------------------- 
    606       LOGICAL :: setto, for_all 
    607       TYPE(sn_ctl) :: sn_cfctl 
    608       !!---------------------------------------------------------------------- 
    609       IF( for_all ) THEN 
    610          sn_cfctl%l_runstat = setto 
    611          sn_cfctl%l_trcstat = setto 
    612       ENDIF 
     439      !!                types of output for selected areas. 
     440      !!---------------------------------------------------------------------- 
     441      TYPE(sn_ctl), INTENT(inout) :: sn_cfctl 
     442      LOGICAL     , INTENT(in   ) :: setto 
     443      !!---------------------------------------------------------------------- 
     444      sn_cfctl%l_runstat = setto 
     445      sn_cfctl%l_trcstat = setto 
    613446      sn_cfctl%l_oceout  = setto 
    614447      sn_cfctl%l_layout  = setto 
    … …  
    620453   !!====================================================================== 
    621454END MODULE nemogcm 
    622  

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/stpctl.F90

    r14037 r14062  
    33   !!                       ***  MODULE  stpctl  *** 
    44   !! Ocean run control :  gross check of the ocean time stepping 
     5   !!              *** Shallow Water Equation (SWE) case *** 
     6   !!               ( No test on temperature and salinity ) 
    57   !!====================================================================== 
    6    !! History :  OPA  ! 1991-03  (G. Madec) Original code 
    7    !!            6.0  ! 1992-06  (M. Imbard) 
    8    !!            8.0  ! 1997-06  (A.M. Treguier) 
    9    !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
    10    !!            2.0  ! 2009-07  (G. Madec)  Add statistic for time-spliting 
    11    !!            3.7  ! 2016-09  (G. Madec)  Remove solver 
    12    !!            4.0  ! 2017-04  (G. Madec)  regroup global communications 
     8   !! History :  SWE  ! 2020-09  (A. Nasser, S. Techene ) OCE/stpctl adaptated to SWE 
    139   !!---------------------------------------------------------------------- 
    1410 
    … …  
    2117   USE zdf_oce ,  ONLY : ln_zad_Aimp       ! ocean vertical physics variables 
    2218   USE wet_dry,   ONLY : ll_wd, ssh_ref    ! reference depth for negative bathy 
    23    !   
     19   ! 
    2420   USE diawri          ! Standard run outputs       (dia_wri_state routine) 
    2521   USE in_out_manager  ! I/O manager 
    2622   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2723   USE lib_mpp         ! distributed memory computing 
    28    ! 
    2924   USE netcdf          ! NetCDF library 
     25 
    3026   IMPLICIT NONE 
    3127   PRIVATE 
    … …  
    3531   INTEGER                ::   nrunid   ! netcdf file id 
    3632   INTEGER, DIMENSION(2)  ::   nvarid   ! netcdf variable id 
     33 
     34#  include "domzgr_substitute.h90" 
    3735   !!---------------------------------------------------------------------- 
    3836   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4947      !! 
    5048      !! ** Method  : - Save the time step in numstp 
     49      !!              - Print it each 50 time steps 
    5150      !!              - Stop the run IF problem encountered by setting nstop > 0 
    52       !!                Problems checked: negative sea surface height  
     51      !!                Problems checked: e3t0+ssh minimum smaller that 0 
    5352      !!                                  |U|   maximum larger than 10 m/s  
     53      !!                                  ( not for SWE : negative sea surface salinity ) 
    5454      !! 
    5555      !! ** Actions :   "time.step" file = last ocean time-step 
    … …  
    6363      INTEGER                         ::   idtime, istatus 
    6464      INTEGER , DIMENSION(3)          ::   iareasum, iareamin, iareamax 
    65       INTEGER , DIMENSION(3,2)        ::   iloc                                  ! min/max loc indices 
     65      INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
    6666      REAL(wp)                        ::   zzz                                   ! local real  
    6767      REAL(wp), DIMENSION(3)          ::   zmax, zmaxlocal 
    … …  
    7070      CHARACTER(len=20)               ::   clname 
    7171      !!---------------------------------------------------------------------- 
     72      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
     73      ! 
    7274      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
    7375      ! 
    … …  
    109111      !                                   !==            test of local extrema           ==! 
    110112      !                                   !==  done by all processes at every time step  ==! 
    111       ! 
    112       llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
    113       llmsk(Nie1: jpi,:,:) = .FALSE. 
    114       llmsk(:,   1:Njs1,:) = .FALSE. 
    115       llmsk(:,Nje1: jpj,:) = .FALSE. 
    116       ! 
     113      zmax(1) = MINVAL( e3t_0(:,:,1)+ssh(:,:,Kmm)  )                              ! e3t_Kmm min 
     114      llmsk(:,:,:) = umask(:,:,:) == 1._wp 
     115      zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) ), mask = llmsk )                     ! velocity max (zonal only) 
     116      zmax(3) = REAL( nstop , wp )                                            ! stop indicator 
     117      !                                   !==               get global extrema             ==! 
     118      !                                   !==  done by all processes if writting run.stat  ==! 
    117119      llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
    118120      zmax(1) = MAXVAL(     -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) )      ! ssh max 
    … …  
    131133      IF( ll_wrtruns ) THEN 
    132134         WRITE(numrun,9500) kt, zmax(1), zmax(2) 
    133          istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ -zmax(1)/), (/kt/), (/1/) ) 
    134          istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/  zmax(2)/), (/kt/), (/1/) ) 
     135         istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 
     136         istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 
    135137         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    136       END IF 
     138      ENDIF 
    137139      !                                   !==               error handling               ==! 
    138140      !                                   !==  done by all processes at every time step  ==! 
    139141      ! 
    140       IF(   zmax(1) >  0._wp           .OR.   &               ! negative sea surface height  
    141          &  zmax(2) > 10._wp           .OR.   &               ! too large velocity ( > 10 m/s) 
     142!!SWE specific : start 
     143      IF(   zmax(1) <=   0._wp .OR.           &               ! negative e3t_Kmm 
     144         &  zmax(2) >   10._wp .OR.           &               ! too large velocity ( > 10 m/s) 
    142145         &  ISNAN( zmax(1) + zmax(2) ) .OR.   &               ! NaN encounter in the tests 
    143146         &  ABS(   zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
    … …  
    148151            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
    149152            ! get global loc on the min/max 
    150             llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
    151             CALL mpp_maxloc( 'stpctl',   -e3t(:,:,1,Kmm) , llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
    152             llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    153             CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 
     153            CALL mpp_minloc( 'stpctl', e3t_0(:,:,1) + ssh(:,:,Kmm), ssmask(:,:  ), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
     154            CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,Kmm))        ,  umask(:,:,:), zzz, iloc(1:3,2) ) 
    154155            ! find which subdomain has the max. 
    155156            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    … …  
    164165         ELSE                    ! find local min and max locations: 
    165166            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    166             llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
    167             iloc(1:2,1) = MAXLOC(   -e3t(:,:,1,Kmm) , mask = llmsk(:,:,1) ) 
    168             llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    169             iloc(1:3,2) = MAXLOC( ABS(uu(:,:,:,Kmm)), mask = llmsk(:,:,:) ) 
    170             DO ji = 1, 2   ! local domain indices ==> global domain indices, excluding halos 
    171                iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
    172             END DO 
     167            iloc(1:2,1) = MINLOC( e3t_0(:,:,1) + ssh(:,:,Kmm), mask = ssmask(:,:  ) == 1._wp ) + (/ nimpp - 1, njmpp - 1    /) 
     168            iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask =  umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    173169            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    174170         ENDIF 
    175171         ! 
    176          WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
    177          CALL wrt_line( ctmp2, kt, '|e3t| min', -zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
    178          CALL wrt_line( ctmp3, kt, '|U|   max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     172         WRITE(ctmp1,*) ' stp_ctl:  e3t0+ssh < 0 m  or  |U| > 10 m/s  or  NaN encounter in the tests' 
     173         CALL wrt_line( ctmp2, kt, 'e3t0+ssh min',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     174         CALL wrt_line( ctmp3, kt, '|U|   max'   ,  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
    179175         IF( Agrif_Root() ) THEN 
    180176            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
    … …  
    194190         ! 
    195191      ENDIF 
     192!!SWE specific : end 
    196193      ! 
    197194      IF( nstop > 0 ) THEN                                                  ! an error was detected and we did not abort yet... 
    … …  
    200197      ENDIF 
    201198      ! 
    202 9500  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 
     1999500  FORMAT(' it :', i8, '      e3t_min: ', D23.16, ' |U|_max: ', D23.16) 
    203200      ! 
    204201   END SUBROUTINE stp_ctl 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/TOP/PISCES/SED/oce_sed.F90

    r13237 r14062  
    1313   USE dom_oce , ONLY :   glamt     =>   glamt          !: longitude of t-point (degre) 
    1414   USE dom_oce , ONLY :   gphit     =>   gphit          !: latitude  of t-point (degre) 
    15 !!st  
     15  
    1616#if ! defined key_qco 
    1717   USE dom_oce , ONLY :   e3t       =>   e3t            !: latitude  of t-point (degre) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/TOP/TRP/trcatf.F90

    r13295 r14062  
    3232   USE trdtra 
    3333# if defined key_qco 
    34    USE traatfqco 
     34   USE traatf_qco 
    3535# else 
    3636   USE traatf 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/EXPREF/namelist_cfg_orca025_like

    r14037 r14062  
    178178!----------------------------------------------------------------------- 
    179179   ln_dynvor_een = .true. !  energy & enstrophy scheme 
    180       nn_een_e3f = 0          ! =0  e3f = mi(mj(e3t))/4  
    181       !                       ! =1  e3f = mi(mj(e3t))/mi(mj( tmask)) 
     180   nn_e3f_typ = 0         ! =0  e3f = mi(mj(e3t))/4  
     181   !                      ! =1  e3f = mi(mj(e3t))/mi(mj( tmask)) 
    182182/ 
    183183!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/EXPREF/namelist_cfg_orca12_like

    r14037 r14062  
    177177!----------------------------------------------------------------------- 
    178178   ln_dynvor_een = .true. !  energy & enstrophy scheme 
    179       nn_een_e3f = 0          ! =0  e3f = mi(mj(e3t))/4  
     179      nn_e3f_typ = 0          ! =0  e3f = mi(mj(e3t))/4  
    180180      !                       ! =1  e3f = mi(mj(e3t))/mi(mj( tmask)) 
    181181/ 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/MY_SRC/usrdef_istate.F90

    r13295 r14062  
    2626   PRIVATE 
    2727 
    28    PUBLIC   usr_def_istate   ! called by istate.F90 
     28   PUBLIC   usr_def_istate       ! called by istate.F90 
     29   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
    2930 
    3031   !! * Substitutions 
    … …  
    3738CONTAINS 
    3839   
    39    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     40   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) !!st, pssh ) 
    4041      !!---------------------------------------------------------------------- 
    4142      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    5253      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    5354      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    54       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
     55!!st      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5556      ! 
    5657      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! 2D workspace 
    … …  
    7980      ! 
    8081      ! sea level: 
    81       pssh(:,:) = z2d(:,:)                                                ! +/- 0.05 m 
     82!!st      pssh(:,:) = z2d(:,:)                                                ! +/- 0.05 m 
    8283      ! 
    8384      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    … …  
    9596      pv( :,:,jpk  ) = 0._wp 
    9697      ! 
    97       CALL lbc_lnk('usrdef_istate', pssh, 'T',  1. )            ! apply boundary conditions 
     98!!st      CALL lbc_lnk('usrdef_istate', pssh, 'T',  1. )            ! apply boundary conditions 
    9899      CALL lbc_lnk('usrdef_istate',  pts, 'T',  1. )            ! apply boundary conditions 
    99100      CALL lbc_lnk('usrdef_istate',   pu, 'U', -1. )            ! apply boundary conditions 
    … …  
    102103   END SUBROUTINE usr_def_istate 
    103104 
     105 
     106   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     107      !!---------------------------------------------------------------------- 
     108      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     109      !!  
     110      !! ** Purpose :   Initialization of ssh 
     111      !!                Here BENCH configuration  
     112      !! 
     113      !! ** Method  :   Set ssh 
     114      !!---------------------------------------------------------------------- 
     115      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     116      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     117      ! 
     118      INTEGER  ::   ji, jj 
     119      INTEGER  ::   igloi, igloj   ! to be removed in the future, see usr_def_istate comment  
     120      !!---------------------------------------------------------------------- 
     121      ! 
     122      IF(lwp) WRITE(numout,*) 
     123      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : BENCH configuration, analytical definition of initial ssh' 
     124      ! 
     125      igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 
     126      igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) ) 
     127      ! sea level:  +/- 0.05 m 
     128      DO_2D( 0, 0, 0, 0 ) 
     129         pssh(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) ) 
     130      END_2D 
     131      ! 
     132      CALL lbc_lnk('usrdef_istate', pssh, 'T',  1. )            ! apply boundary conditions 
     133      ! 
     134   END SUBROUTINE usr_def_istate_ssh 
     135    
    104136   !!====================================================================== 
    105137END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CANAL/EXPREF/namelist_cfg

    r14037 r14062  
    235235   ln_dynvor_mix = .false.  !  mixed scheme 
    236236   ln_dynvor_een = .false.  !  energy & enstrophy scheme 
    237    ln_dynvor_enT = .false.  !  energy conserving scheme (T-point) 
     237r_enT = .false.  !  energy conserving scheme (T-point) 
    238238   ln_dynvor_eeT = .true.   !  energy conserving scheme (een using e3t) 
    239       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
     239      nn_e3f_typ = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    240240/ 
    241241!----------------------------------------------------------------------- 
    … …  
    319319!!   namdiu       Cool skin and warm layer models                       (default: OFF) 
    320320!!   namdiu       Cool skin and warm layer models                       (default: OFF) 
    321 <<<<<<< .working 
    322 !!   namflo       float parameters                                      (default: OFF) 
    323 !!   nam_diadct   transports through some sections                      (default: OFF) 
    324 ||||||| .merge-left.r13465 
    325 !!   namflo       float parameters                                      (default: OFF) 
    326 !!   nam_diaharm  Harmonic analysis of tidal constituents               (default: OFF) 
    327 !!   nam_diadct   transports through some sections                      (default: OFF) 
    328 ======= 
    329321!!   namflo       float parameters                                      ("key_float") 
    330322!!   nam_diaharm  Harmonic analysis of tidal constituents               ("key_diaharm") 
    331323!!   namdct       transports through some sections                      ("key_diadct") 
    332324!!   nam_diatmb   Top Middle Bottom Output                              (default: OFF) 
    333 >>>>>>> .merge-right.r13470 
    334325!!   nam_dia25h   25h Mean Output                                       (default: OFF) 
    335326!!   namnc4       netcdf4 chunking and compression settings             ("key_netcdf4") 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CANAL/MY_SRC/usrdef_istate.F90

    r14037 r14062  
    2626   PRIVATE 
    2727 
    28    PUBLIC   usr_def_istate   ! called by istate.F90 
     28   PUBLIC   usr_def_istate       ! called by istate.F90 
     29   PUBLIC   usr_def_istate_ssh   ! called by sshwzv.F90 
    2930 
    3031   !! * Substitutions 
    … …  
    3738CONTAINS 
    3839   
    39    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     40   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    4041      !!---------------------------------------------------------------------- 
    4142      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    5253      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    5354      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    54       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5555      ! 
    5656      INTEGER  :: ji, jj, jk, jl  ! dummy loop indices 
    … …  
    8787 
    8888      CASE(0)    ! rest 
    89           
    90          ! sea level: 
    91          pssh(:,:) = 0. 
     89         ! 
    9290         ! temperature: 
    9391         pts(:,:,:,jp_tem) = 10._wp 
    … …  
    9997          
    10098      CASE(1)    ! geostrophic zonal jet from -zjety to +zjety 
    101  
    102          ! sea level: 
    103          SELECT CASE( nn_fcase ) 
    104          CASE(0)    ! f = f0 
    105             ! sea level: ssh = - fuy / g 
    106             WHERE( ABS(gphit) <= zjety ) 
    107                pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 
    108             ELSEWHERE 
    109                pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 
    110             END WHERE 
    111          CASE(1)    ! f = f0 + beta*y 
    112             ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 
    113             zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 
    114             WHERE( ABS(gphit) <= zjety ) 
    115                pssh(:,:) = - rn_uzonal / grav * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 
    116             ELSEWHERE 
    117                pssh(:,:) = - rn_uzonal / grav * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3   & 
    118                   &                             + 0.5 * zbeta * zjety * zjety * 1.e6 ) 
    119             END WHERE 
    120          END SELECT 
     99         ! 
    121100         ! temperature: 
    122101         pts(:,:,:,jp_tem) = 10._wp 
    … …  
    139118         !                   
    140119      CASE(2)    ! geostrophic zonal current shear 
    141        
    142          ! sea level: 
    143          SELECT CASE( nn_fcase ) 
    144          CASE(0)    ! f = f0 
    145             ! sea level: ssh = - fuy / g 
    146             WHERE( ABS(gphit) <= zjety ) 
    147                pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 
    148             ELSEWHERE 
    149                pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 
    150             END WHERE 
    151          CASE(1)    ! f = f0 + beta*y 
    152             ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 
    153             zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 
    154             WHERE( ABS(gphit) <= zjety ) 
    155                pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav   & 
    156                   &        * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 
    157             ELSEWHERE 
    158                pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav   & 
    159                   &        * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 
    160             END WHERE 
    161          END SELECT 
     120         ! 
    162121         ! temperature: 
    163122         pts(:,:,:,jp_tem) = 10._wp 
    … …  
    176135         !                   
    177136      CASE(3)    ! gaussian zonal currant 
    178  
     137         ! 
    179138         ! zonal current 
    180139         DO jk=1, jpkm1 
    … …  
    182141            pu(:,:,jk) = rn_uzonal * EXP( - 0.5 * gphit(:,:)**2 / rn_lambda**2 ) 
    183142         END DO 
    184           
    185          ! sea level: 
    186          pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1) 
    187          DO jl=1, jpnj 
    188             DO_2D( 0, 0, 0, 0 ) 
    189                pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) 
    190             END_2D 
    191             CALL lbc_lnk( 'usrdef_istate', pssh, 'T',  1. ) 
    192          END DO 
    193           
    194143         ! temperature: 
    195144         pts(:,:,:,jp_tem) = 10._wp 
    … …  
    202151         !             
    203152      CASE(4)    ! geostrophic zonal pulse 
    204     
     153         ! 
    205154         DO_2D( 1, 1, 1, 1 ) 
    206155            IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 
    … …  
    210159            ELSE 
    211160               zdu = 0. 
    212             END IF 
     161            ENDIF 
    213162            IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 
    214                pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 
    215163               pu(ji,jj,:) = zdu 
    216164               pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 
    217165            ELSE 
    218                pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav  
    219166               pu(ji,jj,:) = 0. 
    220167               pts(ji,jj,:,jp_sal) = 1. 
    221             END IF 
    222          END_2D 
    223           
     168            ENDIF 
     169         END_2D 
     170         ! 
    224171         ! temperature: 
    225172         pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:)         
    226173         pv(:,:,:) = 0. 
    227           
    228        CASE(5)    ! vortex 
    229                   ! 
     174         ! 
     175      CASE(5)    ! vortex 
     176         ! 
    230177         zf0   = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 
    231          zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 
     178         zumax = rn_vtxmax * SIGN(1._wp, zf0)  ! Here Anticyclonic: set zumax=-1 for cyclonic 
    232179         zlambda = SQRT(2._wp)*rn_lambda*1.e3       ! Horizontal scale in meters  
    233180         zn2 = 3.e-3**2 
    … …  
    242189            ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 
    243190            zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 
    244             ! Sea level: 
    245             pssh(ji,jj) = 0. 
    246             DO jl=1,5 
    247                zdt = pssh(ji,jj) 
    248                zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH))   ! F'(z) 
    249                zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
    250                pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1)   ! ssh = Psurf / (Rho*g) 
    251             END DO 
    252191            ! temperature: 
    253192            DO jk=1,jpk 
    … …  
    299238         !             
    300239      END SELECT 
    301        
     240      ! 
     241      CALL lbc_lnk( 'usrdef_istate', pts , 'T',  1. ) 
     242      CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 
     243 
     244   END SUBROUTINE usr_def_istate 
     245 
     246   
     247   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     248      !!---------------------------------------------------------------------- 
     249      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     250      !!  
     251      !! ** Purpose :   Initialization of the dynamics and tracers 
     252      !!                Here CANAL configuration  
     253      !! 
     254      !! ** Method  :   Set ssh  
     255      !!---------------------------------------------------------------------- 
     256      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask             [m] 
     257      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
     258      ! 
     259      INTEGER  :: ji, jj, jk, jl  ! dummy loop indices 
     260      REAL(wp) :: zx, zy, zP0, zumax, zlambda, zr_lambda2, zn2, zf0, zH, zrho1, za, zf, zdzF 
     261      REAL(wp) :: zpsurf, zdyPs, zdxPs 
     262      REAL(wp) :: zdt, zdu, zdv 
     263      REAL(wp) :: zjetx, zjety, zbeta 
     264      REAL(wp), DIMENSION(jpi,jpj)  ::   zrandom 
     265      !!---------------------------------------------------------------------- 
     266      ! 
     267      IF(lwp) WRITE(numout,*) 
     268      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : CANAL configuration, analytical definition of initial state' 
     269      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   ' 
     270      ! 
     271      IF (ln_sshnoise) CALL RANDOM_NUMBER(zrandom) 
     272      zjetx = ABS(rn_ujetszx)/2. 
     273      zjety = ABS(rn_ujetszy)/2. 
     274      ! 
     275      SELECT CASE(nn_initcase) 
     276      CASE(0)                      !==   rest  ==! 
     277         ! 
     278         pssh(:,:) = 0. 
     279         ! 
     280      CASE(1)                      !==  geostrophic zonal jet from -zjety to +zjety  ==! 
     281         ! 
     282         SELECT CASE( nn_fcase ) 
     283         CASE(0)                          !* f = f0 : ssh = - fuy / g 
     284            WHERE( ABS(gphit) <= zjety ) 
     285               pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 
     286            ELSEWHERE 
     287               pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 
     288            END WHERE 
     289         CASE(1)                          !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 
     290            zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 
     291            WHERE( ABS(gphit) <= zjety ) 
     292               pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 
     293            ELSEWHERE 
     294               pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3   & 
     295                  &                             + 0.5 * zbeta * zjety * zjety * 1.e6 ) 
     296            END WHERE 
     297         END SELECT 
     298         !                   
     299      CASE(2)                      !==  geostrophic zonal current shear  ==! 
     300         ! 
     301         SELECT CASE( nn_fcase ) 
     302         CASE(0)                          !* f = f0 : ssh = - fuy / g 
     303            WHERE( ABS(gphit) <= zjety ) 
     304               pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 
     305            ELSEWHERE 
     306               pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 
     307            END WHERE 
     308         CASE(1)                          !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 
     309            zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 
     310            WHERE( ABS(gphit) <= zjety ) 
     311               pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav   & 
     312                  &        * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 
     313            ELSEWHERE 
     314               pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav   & 
     315                  &        * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 
     316            END WHERE 
     317         END SELECT 
     318         !                   
     319      CASE(3)                      !==  gaussian zonal currant  ==! 
     320         ! 
     321         pssh(:,1) = - ff_t(:,1) / grav * e2t(:,1) * rn_uzonal * EXP( - 0.5 * gphit(:,1)**2 / rn_lambda**2 ) 
     322         DO jl=1, jpnj 
     323            DO_2D( 0, 0, 0, 0 ) 
     324               pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * rn_uzonal * EXP( - 0.5 * gphit(ji,jj)**2 / rn_lambda**2 ) * e2t(ji,jj) 
     325            END_2D 
     326            CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T',  1. ) 
     327         END DO 
     328         !             
     329      CASE(4)                      !==  geostrophic zonal pulse !!st need to implement a way to separate ssh properly  ==! 
     330         ! 
     331         DO_2D( 1, 1, 1, 1 ) 
     332            IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 
     333               zdu = rn_uzonal 
     334            ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 
     335               zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 
     336            ELSE 
     337               zdu = 0. 
     338            ENDIF 
     339            IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 
     340               pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 
     341            ELSE 
     342               pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav  
     343            ENDIF 
     344         END_2D 
     345         ! 
     346      CASE(5)                    !==  vortex  ==! 
     347         ! 
     348         zf0   = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 
     349         zumax = rn_vtxmax * SIGN(1._wp, zf0)   ! Here Anticyclonic: set zumax=-1 for cyclonic 
     350         zlambda = SQRT(2._wp)*rn_lambda        ! Horizontal scale in meters  
     351         zn2 = 3.e-3**2 
     352         zH = 0.5_wp * 5000._wp 
     353         ! 
     354         zr_lambda2 = 1._wp / zlambda**2 
     355         zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 
     356         ! 
     357         DO_2D( 1, 1, 1, 1 ) 
     358            zx = glamt(ji,jj) * 1.e3 
     359            zy = gphit(ji,jj) * 1.e3 
     360            !                                   ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 
     361            zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 
     362            pssh(ji,jj) = 0. 
     363            DO jl=1,5 
     364               zdt = pssh(ji,jj) 
     365               zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH))   ! F'(z) 
     366               zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
     367               pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1)   ! ssh = Psurf / (Rho*g) 
     368            END DO 
     369         END_2D 
     370         !             
     371      END SELECT 
     372      !                          !==  add noise  ==! 
    302373      IF (ln_sshnoise) THEN 
    303374         CALL RANDOM_SEED() 
    304375         CALL RANDOM_NUMBER(zrandom) 
    305376         pssh(:,:) = pssh(:,:) + ( 0.1  * zrandom(:,:) - 0.05 ) 
    306       END IF 
    307       CALL lbc_lnk( 'usrdef_istate', pssh, 'T',  1. ) 
    308       CALL lbc_lnk( 'usrdef_istate', pts , 'T',  1. ) 
    309       CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 
    310  
    311    END SUBROUTINE usr_def_istate 
    312  
     377      ENDIF 
     378      CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T',  1. ) 
     379      ! 
     380   END SUBROUTINE usr_def_istate_ssh 
     381    
    313382   !!====================================================================== 
    314383END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CPL_OASIS/EXPREF/namelist_cfg

    r14037 r14062  
    367367!----------------------------------------------------------------------- 
    368368   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    369       nn_een_e3f = 0          ! =0   e3f = mean masked e3t divided by 4 
    370369/ 
    371370!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/ISOMIP+/MY_SRC/istate.F90

    r14037 r14062  
    117117            CALL dta_tsd( nit000, 'ini', ts(:,:,:,:,Kbb) )       ! read 3D T and S data at nit000 
    118118            ! 
    119             ssh(:,:,Kbb)   = 0._wp               ! set the ocean at rest 
    120             uu  (:,:,:,Kbb) = 0._wp 
    121             vv  (:,:,:,Kbb) = 0._wp   
     119            uu (:,:,:,Kbb) = 0._wp 
     120            vv (:,:,:,Kbb) = 0._wp 
    122121            ! 
    123             IF( ll_wd ) THEN 
    124                ssh(:,:,Kbb) =  -ssh_ref  ! Added in 30 here for bathy that adds 30 as Iterative test CEOD  
    125                ! 
    126                ! Apply minimum wetdepth criterion 
    127                ! 
    128                DO_2D( 1, 1, 1, 1 ) 
    129                   IF( ht_0(ji,jj) + ssh(ji,jj,Kbb)  < rn_wdmin1 ) THEN 
    130                      ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) 
    131                   ENDIF 
    132                END_2D 
    133             ENDIF  
    134              ! 
    135122         ELSE                                 ! user defined initial T and S 
    136123            DO jk = 1, jpk 
    137124               zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 
    138125            END DO 
    139             CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  )          
     126            CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb)  )          
    140127         ENDIF 
    141128         ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    142          ssh (:,:,Kmm)     = ssh(:,:,Kbb)    
    143129         uu   (:,:,:,Kmm)   = uu  (:,:,:,Kbb) 
    144130         vv   (:,:,:,Kmm)   = vv  (:,:,:,Kbb) 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/ISOMIP/MY_SRC/usrdef_istate.F90

    r10074 r14062  
    99   !! History :  NEMO ! 2016-11 (S. Flavoni)             Original code 
    1010   !!                 ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case 
     11   !!                 ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2425   PRIVATE 
    2526 
    26    PUBLIC   usr_def_istate   ! called by istate.F90 
     27   PUBLIC   usr_def_istate       ! called by istate.F90 
     28   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
    2729 
    2830   !!---------------------------------------------------------------------- 
    … …  
    3335CONTAINS 
    3436   
    35    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     37   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3638      !!---------------------------------------------------------------------- 
    3739      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    4850      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    4951      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    50       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    51       ! 
    52       INTEGER  ::   jk     ! dummy loop indices 
    5352      !!---------------------------------------------------------------------- 
    5453      ! 
    … …  
    5857      pu  (:,:,:) = 0._wp        ! ocean at rest 
    5958      pv  (:,:,:) = 0._wp 
    60       pssh(:,:)   = 0._wp 
    61       ! 
    6259      !                          ! T & S profiles 
    6360      pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:)          ! ISOMIP configuration : start from constant T+S fields 
    … …  
    6663   END SUBROUTINE usr_def_istate 
    6764 
     65 
     66   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     67      !!---------------------------------------------------------------------- 
     68      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     69      !!  
     70      !! ** Purpose :   Initialization of ssh 
     71      !!                Here ISOMIP configuration  
     72      !! 
     73      !! ** Method  :   set ssh to 0 
     74      !!---------------------------------------------------------------------- 
     75      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     76      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     77      !!---------------------------------------------------------------------- 
     78      ! 
     79      IF(lwp) WRITE(numout,*) 
     80      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : ISOMIP configuration, analytical definition of initial state' 
     81      ! 
     82      pssh(:,:)   = 0._wp 
     83      ! 
     84   END SUBROUTINE usr_def_istate_ssh 
     85 
    6886   !!====================================================================== 
    6987END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg

    r14037 r14062  
    201201   ln_dynvor_mix = .false. !  mixed scheme 
    202202   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    203       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    204203/ 
    205204!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg

    r14037 r14062  
    129129   ln_dynvor_mix = .false. !  mixed scheme 
    130130   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    131       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    132131/ 
    133132!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90

    r12489 r14062  
    88   !!====================================================================== 
    99   !! History :  NEMO ! 2016-03  (S. Flavoni, G. Madec) Original code 
     10   !!                 ! 2020-11  (S. Techene, G. Madec) separate tsuv from ssh 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2324   PRIVATE 
    2425 
    25    PUBLIC   usr_def_istate   ! called by istate.F90 
     26   PUBLIC   usr_def_istate       ! called by istate.F90 
     27   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
    2628 
    2729   !!---------------------------------------------------------------------- 
    … …  
    3234CONTAINS 
    3335   
    34    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     36   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3537      !!---------------------------------------------------------------------- 
    3638      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    4749      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    4850      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    49       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5051      ! 
    5152      INTEGER  ::   jk     ! dummy loop indices 
    … …  
    6566      pu  (:,:,:) = 0._wp        ! ocean at rest 
    6667      pv  (:,:,:) = 0._wp 
    67       pssh(:,:)   = 0._wp 
    6868      ! 
    6969      !                          ! T & S profiles 
    … …  
    7878   END SUBROUTINE usr_def_istate 
    7979 
     80 
     81   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     82      !!---------------------------------------------------------------------- 
     83      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     84      !!  
     85      !! ** Purpose :   Initialization of ssh 
     86      !!                Here LOCK_EXCHANGE configuration  
     87      !! 
     88      !! ** Method  :   set ssh to 0 
     89      !!---------------------------------------------------------------------- 
     90      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     91      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     92      !!---------------------------------------------------------------------- 
     93      ! 
     94      IF(lwp) WRITE(numout,*) 
     95      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : LOCK_EXCHANGE configuration, analytical definition of initial state' 
     96      ! 
     97      pssh(:,:)   = 0._wp 
     98      ! 
     99   END SUBROUTINE usr_def_istate_ssh 
     100 
    80101   !!====================================================================== 
    81102END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg

    r14037 r14062  
    201201   ln_dynvor_mix = .false. !  mixed scheme 
    202202   ln_dynvor_een = .false. !  energy & enstrophy scheme 
    203       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    204203/ 
    205204!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg

    r14037 r14062  
    139139   ln_dynvor_mix = .false. !  mixed scheme 
    140140   ln_dynvor_een = .true. !  energy & enstrophy scheme 
    141       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    142141/ 
    143142!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/MY_SRC/usrdef_istate.F90

    r12489 r14062  
    88   !!============================================================================== 
    99   !! History :  NEMO ! 2016-03  (S. Flavoni, G. Madec) Original code 
     10   !!                 ! 2020-11  (S. Techene, G. Madec) separate tsuv from ssh 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2324   PRIVATE 
    2425 
    25    PUBLIC   usr_def_istate   ! called by istate.F90 
    26  
     26   PUBLIC   usr_def_istate       ! called by istate.F90 
     27   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
     28    
    2729   !!---------------------------------------------------------------------- 
    2830   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3234CONTAINS 
    3335   
    34    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     36   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3537      !!---------------------------------------------------------------------- 
    3638      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    4749      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    4850      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    49       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5051      ! 
    5152      INTEGER  ::   jk     ! dummy loop indices 
    … …  
    6566      pu  (:,:,:) = 0._wp        ! ocean at rest 
    6667      pv  (:,:,:) = 0._wp 
    67       pssh(:,:)   = 0._wp 
    6868      ! 
    6969      !                          ! T & S profiles 
    … …  
    7878   END SUBROUTINE usr_def_istate 
    7979 
     80 
     81   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     82      !!---------------------------------------------------------------------- 
     83      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     84      !!  
     85      !! ** Purpose :   Initialization of the ssh 
     86      !!                Here  OVERFLOW configuration  
     87      !! 
     88      !! ** Method  :   set ssh to 0 
     89      !!---------------------------------------------------------------------- 
     90      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     91      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     92      !!---------------------------------------------------------------------- 
     93      ! 
     94      IF(lwp) WRITE(numout,*) 
     95      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : OVERFLOW configuration, analytical definition of initial state' 
     96      ! 
     97      pssh(:,:)   = 0._wp 
     98      ! 
     99   END SUBROUTINE usr_def_istate_ssh 
     100 
    80101   !!====================================================================== 
    81102END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90

    r13295 r14062  
    193193            pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp 
    194194            pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik)              ! = pe3t (ji,jj,ik  ) 
     195            pe3w (ji,jj,ik  ) = pdept(ji,jj,ik  ) - pdept(ji,jj,ik-1)            ! st caution ik > 1 
    195196         END_2D          
    196197         !                                   ! bottom scale factors and depth at  U-, V-, UW and VW-points 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/EXPREF/1_namelist_cfg

    r14037 r14062  
    195195   ln_dynvor_mix = .false. !  mixed scheme 
    196196   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    197       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    198197/ 
    199198!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/EXPREF/namelist_cfg

    r14037 r14062  
    188188   ln_dynvor_mix = .false. !  mixed scheme 
    189189   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    190       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    191190/ 
    192191!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/MY_SRC/usrdef_istate.F90

    r13295 r14062  
    88   !!====================================================================== 
    99   !! History :  NEMO ! 2017-11  (J. Chanut) Original code 
     10   !!                 ! 2020-11  (S. Techene, G. Madec) separate tsuv from ssh 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2627   PRIVATE 
    2728 
    28    PUBLIC   usr_def_istate   ! called by istate.F90 
     29   PUBLIC   usr_def_istate       ! called by istate.F90 
     30   PUBLIC   usr_def_istate_ssh   ! called by domqco.F90 
    2931 
    3032   !! * Substitutions 
    … …  
    3739CONTAINS 
    3840   
    39    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     41   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    4042      !!---------------------------------------------------------------------- 
    4143      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    5254      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    5355      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    54       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5556      ! 
    5657      INTEGER  :: ji, jj, jk  ! dummy loop indices 
    … …  
    6768      zf0   = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 
    6869      zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 
    69       zlambda = SQRT(2._wp)*60.e3      ! Horizontal scale in meters  
     70      zlambda = SQRT(2._wp)*60.e3      ! Horizontal scale in meters 
    7071      zn2 = 3.e-3**2 
    7172      zH = 0.5_wp * 5000._wp 
    7273      ! 
    7374      zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 
    74       ! 
    75       ! Sea level: 
    76       za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH))) 
    77       DO_2D( 1, 1, 1, 1 ) 
    78          zx = glamt(ji,jj) * 1.e3 
    79          zy = gphit(ji,jj) * 1.e3 
    80          zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2) 
    81          pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1) 
    82       END_2D 
    8375      ! 
    8476      ! temperature:          
    … …  
    134126   END SUBROUTINE usr_def_istate 
    135127 
     128 
     129   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     130      !!---------------------------------------------------------------------- 
     131      !!                   ***  ROUTINE usr_def_istate  *** 
     132      !!  
     133      !! ** Purpose :   Initialization of ssh 
     134      !!                Here VORTEX configuration  
     135      !! 
     136      !! ** Method  :   Set ssh according to a gaussian anomaly of pressure and associated 
     137      !!                geostrophic velocities 
     138      !!---------------------------------------------------------------------- 
     139      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask   [m] 
     140      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height   [m] 
     141      ! 
     142      INTEGER  :: ji, jj ! dummy loop indices 
     143      REAL(wp) :: zx, zy, zP0, zumax, zlambda, zf0, zH, zrho1, za 
     144      !!---------------------------------------------------------------------- 
     145      ! 
     146      IF(lwp) WRITE(numout,*) 
     147      IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : VORTEX configuration, analytical definition of initial state' 
     148      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   ' 
     149      ! 
     150      ! 
     151      ! 
     152      zf0   = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 
     153      zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 
     154      zlambda = SQRT(2._wp)*60.e3      ! Horizontal scale in meters  
     155      zH = 0.5_wp * 5000._wp 
     156      ! 
     157      zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 
     158      ! 
     159      ! Sea level: 
     160      za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH))) 
     161      DO_2D( 1, 1, 1, 1 ) 
     162         zx = glamt(ji,jj) * 1.e3 
     163         zy = gphit(ji,jj) * 1.e3 
     164         zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2) 
     165         pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1) 
     166      END_2D 
     167       
     168   END SUBROUTINE usr_def_istate_ssh 
     169 
    136170   !!====================================================================== 
    137171END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/cpp_VORTEX.fcm

    r12208 r14062  
    1  bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif 
     1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif  

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/WAD/EXPREF/namelist_cfg

    r14037 r14062  
    330330   ln_dynvor_mix = .false. !  mixed scheme 
    331331   ln_dynvor_een = .true.  !  energy & enstrophy scheme 
    332       nn_een_e3f = 0             !  e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    333332/ 
    334333!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/WAD/MY_SRC/usrdef_istate.F90

    r13295 r14062  
    77   !! User defined : set the initial state of a user configuration 
    88   !!====================================================================== 
    9    !! History :  4.0 ! 2016-03  (S. Flavoni) Original code 
     9   !! History :  4.0  ! 2016-03  (S. Flavoni) Original code 
     10   !!                 ! 2020-11  (S. Techene, G. Madec) separate tsuv from ssh 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2425   PRIVATE 
    2526 
    26    PUBLIC   usr_def_istate   ! called in istate.F90 
     27   PUBLIC   usr_def_istate       ! called in istate.F90 
     28   PUBLIC   usr_def_istate_ssh   ! called in sshwzv.F90 
    2729 
    2830   !! * Substitutions 
    … …  
    3436   !!---------------------------------------------------------------------- 
    3537CONTAINS 
    36    
    37    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     38 
     39 
     40   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3841      !!---------------------------------------------------------------------- 
    3942      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    4245      !!                Here WAD_TEST_CASES configuration  
    4346      !! 
    44       !! ** Method  : - set temprature field 
     47q      !! ** Method  : - set temprature field 
    4548      !!              - set salinity   field 
    4649      !!---------------------------------------------------------------------- 
    … …  
    5053      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    5154      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    52       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5355      INTEGER  ::   ji, jj            ! dummy loop indices 
    5456      REAL(wp) ::   zi, zj 
    … …  
    6668      pu  (:,:,:) = 0._wp        ! ocean at rest 
    6769      pv  (:,:,:) = 0._wp 
    68       pssh(:,:)   = 0._wp 
    69       ! 
    7070      !                          ! T & S profiles 
    7171      pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) 
    … …  
    8383         CASE ( 1 )                               ! WAD 1 configuration 
    8484            !                                     ! ==================== 
    85             ! 
    8685            IF(lwp) WRITE(numout,*) 
    8786            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 
    8887            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    89             ! 
    90             do ji = 1,jpi 
    91              pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
    92             end do 
    9388            !                                     ! ==================== 
    9489         CASE ( 2, 8 )                            ! WAD 2 configuration 
    9590            !                                     ! ==================== 
    96             ! 
    9791            IF(lwp) WRITE(numout,*) 
    9892            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 
    9993            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    100             ! 
    101             do ji = 1,jpi 
    102              pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
    103             end do 
    10494            !                                     ! ==================== 
    10595         CASE ( 3 )                               ! WAD 3 configuration 
    10696            !                                     ! ==================== 
    107             ! 
    10897            IF(lwp) WRITE(numout,*) 
    10998            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope'  
    11099            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    111             ! 
    112             do ji = 1,jpi 
    113              pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
    114             end do 
     100            !                                     ! ==================== 
     101         CASE ( 4 )                               ! WAD 4 configuration 
     102            !                                     ! ==================== 
     103            IF(lwp) WRITE(numout,*) 
     104            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic bowl, mid-range initial ssh slope'  
     105            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     106            !                                    ! =========================== 
     107         CASE ( 5, 7 )                           ! WAD 5 and 7 configurations 
     108            !                                    ! =========================== 
     109            IF(lwp) WRITE(numout,*) 
     110            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Double slope with shelf' 
     111            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     112            !                                     ! ==================== 
     113         CASE ( 6 )                               ! WAD 6 configuration 
     114            !                                     ! ==================== 
     115            IF(lwp) WRITE(numout,*) 
     116            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel with gaussian ridge'  
     117            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     118            ! 
     119            DO ji = mi0(jpiglo/2), mi0(jpiglo) 
     120               pts(ji,:,:,jp_sal) = 30._wp 
     121            END DO 
     122            ! 
     123            ! 
     124            !                                    ! =========================== 
     125         CASE DEFAULT                            ! NONE existing configuration 
     126            !                                    ! =========================== 
     127            WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded' 
     128            ! 
     129            CALL ctl_stop( ctmp1 ) 
     130            ! 
     131      END SELECT 
     132      ! 
     133   END SUBROUTINE usr_def_istate 
     134 
     135      
     136   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     137      !!---------------------------------------------------------------------- 
     138      !!                   ***  ROUTINE usr_def_istate_ssh  *** 
     139      !!  
     140      !! ** Purpose :   Initialization of the dynamics and tracers 
     141      !!                Here WAD_TEST_CASES configuration  
     142      !! 
     143      !! ** Method  : - set ssh 
     144      !!---------------------------------------------------------------------- 
     145      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask             [m] 
     146      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
     147      INTEGER  ::   ji, jj            ! dummy loop indices 
     148      REAL(wp) ::   zi, zj 
     149      ! 
     150      INTEGER  ::   jk     ! dummy loop indices 
     151      REAL(wp) ::   zdam   ! location of dam [Km] 
     152      !!---------------------------------------------------------------------- 
     153      ! 
     154      ! 
     155      SELECT CASE ( nn_cfg )  
     156         !                                        ! ==================== 
     157         CASE ( 1 )                               ! WAD 1 configuration 
     158            !                                     ! ==================== 
     159            ! 
     160            IF(lwp) WRITE(numout,*) 
     161            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 
     162            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     163            ! 
     164            DO ji = 1,jpi 
     165               pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
     166            END DO 
     167            !                                     ! ==================== 
     168         CASE ( 2, 8 )                            ! WAD 2 configuration 
     169            !                                     ! ==================== 
     170            ! 
     171            IF(lwp) WRITE(numout,*) 
     172            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 
     173            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     174            ! 
     175            DO ji = 1,jpi 
     176               pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
     177            END DO 
     178            !                                     ! ==================== 
     179         CASE ( 3 )                               ! WAD 3 configuration 
     180            !                                     ! ==================== 
     181            ! 
     182            IF(lwp) WRITE(numout,*) 
     183            IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope'  
     184            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     185            ! 
     186            DO ji = 1,jpi 
     187               pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
     188            END DO 
    115189 
    116190            ! 
    … …  
    140214            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    141215            ! 
    142             do ji = 1,jpi 
    143              pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
    144             end do 
     216            DO ji = 1,jpi 
     217               pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 
     218            END DO 
    145219 
    146220            ! 
    … …  
    153227            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    154228            ! 
    155             do ji = 1,jpi 
    156              pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 
    157             end do 
    158             ! 
    159             do ji = mi0(jpiglo/2), mi0(jpiglo) 
    160              pts(ji,:,:,jp_sal) = 30._wp 
    161              pssh(ji,:) = -0.1*ptmask(ji,:,1) 
    162             end do 
     229            DO ji = 1,jpi 
     230               pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 
     231            END DO 
     232            ! 
     233            DO ji = mi0(jpiglo/2), mi0(jpiglo) 
     234               pssh(ji,:) = -0.1*ptmask(ji,:,1) 
     235            END DO 
    163236            ! 
    164237            ! 
    … …  
    182255      END_2D 
    183256      ! 
    184    END SUBROUTINE usr_def_istate 
     257   END SUBROUTINE usr_def_istate_ssh 
    185258 
    186259   !!====================================================================== 

  • NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/demo_cfgs.txt

    r14037 r14062  
    1212STATION_ASF OCE 
    1313CPL_OASIS  OCE TOP ICE NST 
     14SWG OCE SWE 
    1415C1D_ASICS OCE 
    1516ICE_RHEO OCE SAS ICE 
Note: See TracChangeset for help on using the changeset viewer.