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 14200 for NEMO – NEMO

Changeset 14200 for NEMO


Ignore:
Timestamp:
2020-12-17T15:36:44+01:00 (3 years ago)
Author:
mcastril
Message:

Merging r14117 through r14199 into dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final

Location:
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final
Files:
14 deleted
104 edited
10 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm

    r14086 r14200  
    1 bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi key_agrif 
     1bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi key_agrif key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/AMM12/cpp_AMM12.fcm

    r9139 r14200  
    1  bld::tool::fppkeys   key_diainstant key_mpp_mpi key_iomput 
     1 bld::tool::fppkeys   key_diainstant key_mpp_mpi key_iomput key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/C1D_PAPA/cpp_C1D_PAPA.fcm

    r9799 r14200  
    1  bld::tool::fppkeys   key_c1d key_mpp_mpi key_iomput 
     1 bld::tool::fppkeys   key_c1d key_mpp_mpi key_iomput key_linssh 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/GYRE_BFM/cpp_GYRE_BFM.fcm

    r9139 r14200  
    1 bld::tool::fppkeys   key_top key_my_trc key_mpp_mpi key_iomput 
     1bld::tool::fppkeys   key_top key_my_trc key_mpp_mpi key_iomput key_linssh 
    22inc $BFMDIR/src/nemo/bfm.fcm 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/GYRE_PISCES/cpp_GYRE_PISCES.fcm

    r9139 r14200  
    1 bld::tool::fppkeys   key_top key_mpp_mpi key_iomput 
     1bld::tool::fppkeys   key_top key_linssh key_mpp_mpi key_iomput 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/ORCA2_ICE_ABL/cpp_ORCA2_ICE_ABL.fcm

    r14086 r14200  
    1 bld::tool::fppkeys   key_mpp_mpi key_si3 key_iomput 
     1bld::tool::fppkeys   key_mpp_mpi key_si3 key_iomput key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm

    r10425 r14200  
    1 bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi  
     1bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi key_qco  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/ORCA2_SAS_ICE/cpp_ORCA2_SAS_ICE.fcm

    r9664 r14200  
    1  bld::tool::fppkeys   key_si3 key_iomput key_mpp_mpi 
     1 bld::tool::fppkeys   key_si3 key_linssh key_iomput key_mpp_mpi 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/SHARED/field_def_nemo-oce.xml

    r14072 r14200  
    740740  <!-- F grid --> 
    741741  <field_group id="grid_F" grid_ref="grid_F_2D"> 
    742     <field id="e3f"          long_name="F-cell thickness"                    standard_name="cell_thickness"        unit="m"   grid_ref="grid_F_3D" /> 
    743     <field id="e3f_0"        long_name="F-cell thickness"                    standard_name="cell_thickness"        unit="m"   grid_ref="grid_F_3D" /> 
    744     <field id="hf"           long_name="water column height at F point"    standard_name="water_column_height_F"  unit="m"                     /> 
    745     <field id="sKEf"         long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water"   unit="m2/s2" /> 
    746     <field id="relvor"       long_name="relative vorticity"                standard_name="relative_vorticity"     unit="1/s"                   /> 
    747     <field id="plavor"       long_name="planetary vorticity"               standard_name="planetary_vorticity"    unit="1/s"                   /> 
    748     <field id="relpotvor"    long_name="relative potential vorticity"      standard_name="relpot_vorticity"       unit="1/m.s"                 /> 
    749     <field id="abspotvor"    long_name="absolute potential vorticity"      standard_name="abspot_vorticity"       unit="1/m.s"                 /> 
    750     <field id="Ens"          long_name="enstrophy"                         standard_name="enstrophy"              unit="1/m2.s2"               /> 
     742    <field id="e3f"          long_name="F-cell thickness"                      standard_name="cell_thickness"         unit="m"   grid_ref="grid_F_3D" /> 
     743    <field id="e3f_0"        long_name="F-cell thickness"                      standard_name="cell_thickness"         unit="m"   grid_ref="grid_F_3D" /> 
     744    <field id="hf"           long_name="water column height at F point"        standard_name="water_column_height_F"  unit="m"                     /> 
     745    <field id="ssKEf"        long_name="surface kinetic energy at F point"    standard_name="specific_kinetic_energy_of_sea_water"   unit="m2/s2" /> 
     746    <field id="ssrelvor"     long_name="surface relative vorticity"            standard_name="relative_vorticity"     unit="1/s"                   /> 
     747    <field id="ssplavor"     long_name="surface planetary vorticity"           standard_name="planetary_vorticity"    unit="1/s"                   /> 
     748    <field id="ssrelpotvor"  long_name="surface relative potential vorticity"  standard_name="relpot_vorticity"       unit="1/m.s"                 /> 
     749    <field id="ssabspotvor"  long_name="surface absolute potential vorticity"  standard_name="abspot_vorticity"       unit="1/m.s"                 /> 
     750    <field id="ssEns"        long_name="surface enstrophy"                     standard_name="enstrophy"              unit="1/m2.s2"               /> 
    751751  </field_group> 
    752752 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/SHARED/namelist_ref

    r14089 r14200  
    202202!!   namsbc_wave     external fields from wave model                    (ln_wave    =T) 
    203203!!   namberg         iceberg floats                                     (ln_icebergs=T) 
     204!!   namsbc_fwb      freshwater-budget adjustment                       (nn_fwb > 0) 
    204205!!====================================================================== 
    205206! 
    … …  
    382383   sn_rcv_isf    =   'none'                 ,    'no'    ,     ''      ,         ''           ,   '' 
    383384   sn_rcv_icb    =   'none'                 ,    'no'    ,     ''      ,         ''           ,   '' 
    384    sn_rcv_hsig   =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
     385   sn_rcv_hsig   =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    385386   sn_rcv_phioc  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    386387   sn_rcv_sdrfx  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    387    sn_rcv_sdrfy  =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    388    sn_rcv_wper   =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    389    sn_rcv_wnum   =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    390    sn_rcv_wstrf  =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    391    sn_rcv_wdrag  =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
     388   sn_rcv_sdrfy  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     389   sn_rcv_wper   =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     390   sn_rcv_wnum   =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     391   sn_rcv_wstrf  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     392   sn_rcv_wdrag  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    392393   sn_rcv_charn  =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    393394   sn_rcv_taw    =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'U,V' 
    394    sn_rcv_bhd    =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    395    sn_rcv_tusd   =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
    396    sn_rcv_tvsd   =   'none'                 ,    'no'    ,     ''      '         ''           ,   'T' 
     395   sn_rcv_bhd    =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     396   sn_rcv_tusd   =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
     397   sn_rcv_tvsd   =   'none'                 ,    'no'    ,     ''      ,         ''           ,   'T' 
    397398/ 
    398399!----------------------------------------------------------------------- 
    … …  
    653654   !           !                         !  (if <0  months)  !   name    !   (logical) !  (T/F) ! 'monthly' !                  ! pairing  !    filename   ! 
    654655   sn_icb     =  'calving'              ,         -1.        ,'calvingmask',  .true.   , .true. , 'yearly'  , ''               , ''       , '' 
     656/ 
     657!----------------------------------------------------------------------- 
     658&namsbc_fwb    !   freshwater-budget adjustment                         (nn_fwb > 0) 
     659!----------------------------------------------------------------------- 
     660   rn_fwb0     = 0.0          ! Initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2) 
    655661/ 
    656662 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/SPITZ12/cpp_SPITZ12.fcm

    r10425 r14200  
    1  bld::tool::fppkeys key_mpp_mpi key_iomput key_si3 
     1 bld::tool::fppkeys key_mpp_mpi key_iomput key_si3 key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/WED025/EXPREF/namelist_cfg

    • Property svn:executable deleted

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/WED025/EXPREF/namelist_ice_cfg

    • Property svn:executable deleted

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/apdx_DOMAINcfg.tex

    r11693 r14200  
    4646 
    4747\begin{listing} 
    48   \nlst{namdom_domcfg} 
     48%  \nlst{namdom_domcfg} 
     49  \begin{forlines} 
     50!----------------------------------------------------------------------- 
     51&namdom        !   space and time domain (bathymetry, mesh, timestep) 
     52!----------------------------------------------------------------------- 
     53   nn_bathy    =    1      !  compute analyticaly (=0) or read (=1) the bathymetry file 
     54                           !  or compute (2) from external bathymetry 
     55   nn_interp   =    1                          ! type of interpolation (nn_bathy =2)                        
     56   cn_topo     =  'bathymetry_ORCA12_V3.3.nc'  ! external topo file (nn_bathy =2) 
     57   cn_bath     =  'Bathymetry'                 ! topo name in file  (nn_bathy =2) 
     58   cn_lon      =  'nav_lon'                    ! lon  name in file  (nn_bathy =2) 
     59   cn_lat      =  'nav_lat'                    ! lat  name in file  (nn_bathy =2) 
     60   rn_scale    = 1 
     61   rn_bathy    =    0.     !  value of the bathymetry. if (=0) bottom flat at jpkm1 
     62   jphgr_msh   =       0               !  type of horizontal mesh 
     63   ppglam0     =  999999.0             !  longitude of first raw and column T-point (jphgr_msh = 1) 
     64   ppgphi0     =  999999.0             ! latitude  of first raw and column T-point (jphgr_msh = 1) 
     65   ppe1_deg    =  999999.0             !  zonal      grid-spacing (degrees) 
     66   ppe2_deg    =  999999.0             !  meridional grid-spacing (degrees) 
     67   ppe1_m      =  999999.0             !  zonal      grid-spacing (degrees) 
     68   ppe2_m      =  999999.0             !  meridional grid-spacing (degrees) 
     69   ppsur       =   -4762.96143546300   !  ORCA r4, r2 and r05 coefficients 
     70   ppa0        =     255.58049070440   ! (default coefficients) 
     71   ppa1        =     245.58132232490   ! 
     72   ppkth       =      21.43336197938   ! 
     73   ppacr       =       3.0             ! 
     74   ppdzmin     =  999999.              !  Minimum vertical spacing 
     75   pphmax      =  999999.              !  Maximum depth 
     76   ldbletanh   =  .FALSE.              !  Use/do not use double tanf function for vertical coordinates 
     77   ppa2        =  999999.              !  Double tanh function parameters 
     78   ppkth2      =  999999.              ! 
     79   ppacr2      =  999999.              ! 
     80/ 
     81  \end{forlines} 
    4982  \caption{\forcode{&namdom_domcfg}} 
    5083  \label{lst:namdom_domcfg} 
    … …  
    383416\subsubsection[$S$-coordinate (\forcode{ln_sco})]{$S$-coordinate (\protect\np{ln_sco}{ln\_sco})} 
    384417\label{sec:DOMCFG_sco} 
     418 
    385419\begin{listing} 
    386   \nlst{namzgr_sco_domcfg} 
     420%  \nlst{namzgr_sco_domcfg} 
    387421  \caption{\forcode{&namzgr_sco_domcfg}} 
    388422  \label{lst:namzgr_sco_domcfg} 
     423  \begin{forlines} 
     424!----------------------------------------------------------------------- 
     425&namzgr_sco    !   s-coordinate or hybrid z-s-coordinate                (default: OFF) 
     426!----------------------------------------------------------------------- 
     427   ln_s_sh94   = .false.    !  Song & Haidvogel 1994 hybrid S-sigma   (T)| 
     428   ln_s_sf12   = .false.   !  Siddorn & Furner 2012 hybrid S-z-sigma (T)| if both are false the NEMO tanh stretching is applied 
     429   ln_sigcrit  = .false.   !  use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch 
     430                           !  stretching coefficients for all functions 
     431   rn_sbot_min =   10.0    !  minimum depth of s-bottom surface (>0) (m) 
     432   rn_sbot_max = 7000.0    !  maximum depth of s-bottom surface (= ocean depth) (>0) (m) 
     433   rn_hc       =  150.0    !  critical depth for transition to stretched coordinates 
     434                        !!!!!!!  Envelop bathymetry 
     435   rn_rmax     =    0.3    !  maximum cut-off r-value allowed (0<r_max<1) 
     436                        !!!!!!!  SH94 stretching coefficients  (ln_s_sh94 = .true.) 
     437   rn_theta    =    6.0    !  surface control parameter (0<=theta<=20) 
     438   rn_bb       =    0.8    !  stretching with SH94 s-sigma 
     439                        !!!!!!!  SF12 stretching coefficient  (ln_s_sf12 = .true.) 
     440   rn_alpha    =    4.4    !  stretching with SF12 s-sigma 
     441   rn_efold    =    0.0    !  efold length scale for transition to stretched coord 
     442   rn_zs       =    1.0    !  depth of surface grid box 
     443                           !  bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b 
     444   rn_zb_a     =    0.024  !  bathymetry scaling factor for calculating Zb 
     445   rn_zb_b     =   -0.2    !  offset for calculating Zb 
     446                        !!!!!!!! Other stretching (not SH94 or SF12) [also uses rn_theta above] 
     447   rn_thetb    =    1.0    !  bottom control parameter  (0<=thetb<= 1) 
     448/ 
     449  \end{forlines} 
    389450\end{listing} 
    390 Options are defined in \nam{zgr_sco}{zgr\_sco} (\texttt{DOMAINcfg} only). 
     451 
     452Options are defined in \forcode{&zgr_sco} (\texttt{DOMAINcfg} only). 
    391453In $s$-coordinate (\np[=.true.]{ln_sco}{ln\_sco}), the depth and thickness of the model levels are defined from 
    392454the product of a depth field and either a stretching function or its derivative, respectively: 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_DYN.tex

    r14113 r14200  
    763763which imposes a very small time step when an explicit time stepping is used. 
    764764Two methods are proposed to allow a longer time step for the three-dimensional equations: 
    765 the filtered free surface, which is a modification of the continuous equations (see \autoref{eq:MB_flt?}), 
     765the filtered free surface, which is a modification of the continuous equations \iffalse (see \autoref{eq:MB_flt?}) \fi 
    766766and the split-explicit free surface described below. 
    767767The extra term introduced in the filtered method is calculated implicitly, 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_LBC.tex

    r14113 r14200  
    372372The number of boundary sets is defined by \np{nb_bdy}{nb\_bdy}. 
    373373Each boundary set can be either defined as a series of straight line segments directly in the namelist 
    374 (\np[=.false.]{ln_coords_file}{ln\_coords\_file}, and a namelist block \nam{bdy_index}{bdy\_index} must be included for each set) or read in from a file (\np[=.true.]{ln_coords_file}{ln\_coords\_file}, and a ``\ifile{coordinates.bdy}'' file must be provided). 
     374(\np[=.false.]{ln_coords_file}{ln\_coords\_file}, and a namelist block \forcode{&nambdy_index} must be included for each set) or read in from a file (\np[=.true.]{ln_coords_file}{ln\_coords\_file}, and a ``\ifile{coordinates.bdy}'' file must be provided). 
    375375The coordinates.bdy file is analagous to the usual \NEMO\ ``\ifile{coordinates}'' file. 
    376376In the example above, there are two boundary sets, the first of which is defined via a file and 
    … …  
    569569\autoref{fig:LBC_bdy_geom} shows an example of an irregular boundary. 
    570570 
    571 The boundary geometry for each set may be defined in a namelist nambdy\_index or 
     571The boundary geometry for each set may be defined in a namelist \forcode{&nambdy_index} or 
    572572by reading in a ``\ifile{coordinates.bdy}'' file. 
    573 The nambdy\_index namelist defines a series of straight-line segments for north, east, south and west boundaries. 
    574 One nambdy\_index namelist block is needed for each boundary condition defined by indexes. 
     573The \texttt{nambdy\_index} namelist defines a series of straight-line segments for north, east, south and west boundaries. 
     574One \texttt{nambdy\_index} namelist block is needed for each boundary condition defined by indexes. 
    575575For the northern boundary, \texttt{nbdysegn} gives the number of segments, 
    576576\jp{jpjnob} gives the $j$ index for each segment and \jp{jpindt} and 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_OBS.tex

    r11708 r14200  
    892892\subsubsection{Running} 
    893893 
    894 The simplest way to use the executable is to edit and append the \textbf{sao.nml} namelist to 
     894The simplest way to use the executable is to edit and append the \nam{sao}{sao} namelist to 
    895895a full \NEMO\ namelist and then to run the executable as if it were nemo.exe. 
    896896 
    … …  
    914914For example, to read the second time counter from a single file the namelist would be. 
    915915 
    916 \begin{forlines} 
     916\begin{listing} 
     917%  \nlst{namsao} 
     918  \begin{forlines} 
    917919!---------------------------------------------------------------------- 
    918920!       namsao Standalone obs_oper namelist 
    … …  
    924926   nn_sao_idx = 2 
    925927/ 
    926 \end{forlines} 
     928  \end{forlines} 
     929  \caption{\forcode{&namsao}} 
     930  \label{lst:namsao} 
     931\end{listing} 
    927932 
    928933%% ================================================================================================= 
    … …  
    11191124To plot some data run IDL and then: 
    11201125 
    1121 \begin{minted}{idl} 
     1126\begin{verbatim} 
    11221127IDL> dataplot, "filename" 
    1123 \end{minted} 
     1128\end{verbatim} 
    11241129 
    11251130To read multiple files into dataplot, 
    … …  
    11271132the easiest method is to use the spawn command to generate a list of files which can then be passed to dataplot. 
    11281133 
    1129 \begin{minted}{idl} 
     1134\begin{verbatim} 
    11301135IDL> spawn, 'ls profb*.nc', files 
    11311136IDL> dataplot, files 
    1132 \end{minted} 
     1137\end{verbatim} 
    11331138 
    11341139\autoref{fig:OBS_dataplotmain} shows the main window which is launched when dataplot starts. 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_SBC.tex

    r14116 r14200  
    1616    Release & Author(s) & Modifications \\ 
    1717    \hline 
    18     {\em  next} & {\em Simon M{\" u}ller} & {\em Update of \autoref{sec:SBC_TDE}}\\[2mm] 
     18    {\em  next} & {\em Simon M{\" u}ller} & {\em Update of \autoref{sec:SBC_TDE}; revision of \autoref{subsec:SBC_fwb}}\\[2mm] 
    1919    {\em   4.0} & {\em ...} & {\em ...} \\ 
    2020    {\em   3.6} & {\em ...} & {\em ...} \\ 
    … …  
    664664For the cool-skin scheme parametrization COARE and ECMWF algorithms share the same 
    665665basis: \citet{fairall.bradley.ea_JGRO96}. With some minor updates based 
    666 on \citet{zeng.beljaars_GRL05} for ECMWF, and \citet{fairall.ea_19} for COARE 
     666on \citet{zeng.beljaars_GRL05} for ECMWF \iffalse, and \citet{fairall.ea_19?} for COARE \fi 
    6676673.6. 
    668668 
    … …  
    671671turbulence input from Langmuir circulation). 
    672672 
    673 Importantly, COARE warm-layer scheme \citep{fairall.ea_19} includes a prognostic 
     673Importantly, COARE warm-layer scheme \iffalse \citep{fairall.ea_19?} \fi includes a prognostic 
    674674equation for the thickness of the warm-layer, while it is considered as constant 
    675675in the ECWMF algorithm. 
    … …  
    971971and tidal analysis in the model framework. This includes the computation of the gravitational 
    972972surface forcing, as well as support for lateral forcing at open boundaries (see 
    973 \autoref{subsec:LBC_bdy_tides}) and tidal harmonic analysis (see 
    974 \autoref{subsec:DIA_diamlr} and \autoref{subsec:DIA_diadetide}). The module is 
     973\autoref{subsec:LBC_bdy_tides}) and tidal harmonic analysis \iffalse (see 
     974\autoref{subsec:DIA_diamlr?} and \autoref{subsec:DIA_diadetide?}) \fi . The module is 
    975975activated with \np[=.true.]{ln_tide}{ln\_tide} in namelist 
    976976\nam{_tide}{\_tide}. It provides the same 34 tidal constituents that are 
    … …  
    17771777\label{subsec:SBC_fwb} 
    17781778 
    1779 For global ocean simulation, it can be useful to introduce a control of the mean sea level in order to 
    1780 prevent unrealistic drift of the sea surface height due to inaccuracy in the freshwater fluxes. 
    1781 In \NEMO, two way of controlling the freshwater budget are proposed: 
     1779\begin{listing} 
     1780  \nlst{namsbc_fwb} 
     1781  \caption{\forcode{&namsbc_fwb}} 
     1782  \label{lst:namsbc_fwb} 
     1783\end{listing} 
     1784 
     1785For global ocean simulations, it can be useful to introduce a control of the 
     1786mean sea level in order to prevent unrealistic drifting of the sea surface 
     1787height due to unbalanced freshwater fluxes. In \NEMO, two options for 
     1788controlling the freshwater budget are proposed. 
    17821789 
    17831790\begin{description} 
    1784 \item [{\np[=0]{nn_fwb}{nn\_fwb}}] no control at all. 
    1785   The mean sea level is free to drift, and will certainly do so. 
    1786 \item [{\np[=1]{nn_fwb}{nn\_fwb}}] global mean \textit{emp} set to zero at each model time step. 
     1791\item [{\np[=0]{nn_fwb}{nn\_fwb}}:] No control at all; the mean sea level is 
     1792  free to drift, and will certainly do so. 
     1793\item [{\np[=1]{nn_fwb}{nn\_fwb}}:] The global mean \textit{emp} is set to zero at each model time step. 
    17871794  %GS: comment below still relevant ? 
    17881795  %Note that with a sea-ice model, this technique only controls the mean sea level with linear free surface and no mass flux between ocean and ice (as it is implemented in the current ice-ocean coupling). 
    1789 \item [{\np[=2]{nn_fwb}{nn\_fwb}}] freshwater budget is adjusted from the previous year annual mean budget which 
    1790   is read in the \textit{EMPave\_old.dat} file. 
    1791   As the model uses the Boussinesq approximation, the annual mean fresh water budget is simply evaluated from 
    1792   the change in the mean sea level at January the first and saved in the \textit{EMPav.dat} file. 
     1796\item [{\np[=2]{nn_fwb}{nn\_fwb}}:] \textit{emp} is adjusted by adding a 
     1797  spatially uniform, annual-mean freshwater flux that balances the freshwater 
     1798  budget at the end of the previous year; as the model uses the Boussinesq 
     1799  approximation, the freshwater budget can be evaluated from the change in the 
     1800  mean sea level and in the ice and snow mass after the end of each simulation 
     1801  year; at the start of the model run, an initial adjustment flux can be set 
     1802  using parameter \np{rn_rwb0}{rn\_fwb0} in namelist \nam{sbc_fwb}{sbc\_fwb}. 
    17931803\end{description} 
    17941804 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_ZDF.tex

    r14113 r14200  
    731731\subsubsection{Evolution of the boundary layer depth} 
    732732 
    733 The prognostic equation for the depth of the neutral/unstable boundary layer is given by \citep{grant+etal18}, 
     733The prognostic equation for the depth of the neutral/unstable boundary layer is given by \iffalse \citep{grant+etal18?}, \fi 
    734734 
    735735\begin{equation} 
    … …  
    747747equation for the case when the pycnocline has a finite thickness, 
    748748based on the potential energy budget of the OSBL, is the leading term 
    749 \citep{grant+etal18} of a generalization of that used in mixed-layer 
     749\iffalse \citep{grant+etal18?} \fi of a generalization of that used in mixed-layer 
    750750models e.g.\ \citet{kraus.turner_T67}, in which the thickness of the pycnocline is taken to be zero. 
    751751 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_cfgs.tex

    r14113 r14200  
    243243Through \np[=.false.]{ln_read_cfg}{ln\_read\_cfg} in \nam{cfg}{cfg} namelist defined in 
    244244the reference configuration \path{./cfgs/GYRE_PISCES/EXPREF/namelist_cfg} 
    245 analytical definition of grid in GYRE is done in usrdef\_hrg, usrdef\_zgr routines. 
     245analytical definition of grid in GYRE is done in mdl{usrdef\_hrg}, \mdl{usrdef\_zgr} routines. 
    246246Its horizontal resolution (and thus the size of the domain) is determined by 
    247 setting \np{nn_GYRE}{nn\_GYRE} in \nam{usr_def}{usr\_def}: \\ 
    248  
    249 \jp{jpiglo} $= 30 \times$ \np{nn_GYRE}{nn\_GYRE} + 2  \\ 
    250  
    251 \jp{jpjglo} $= 20 \times$ \np{nn_GYRE}{nn\_GYRE} + 2   \\ 
     247setting \np{nn_GYRE}{nn\_GYRE} in \nam{usr_def}{usr\_def}: 
     248\begin{align*} 
     249  \jp{jpiglo} = 30 \times \text{\np{nn_GYRE}{nn\_GYRE}} + 2 + 2 \times \text{\np{nn_hls}{nn\_hls}} \\ 
     250  \jp{jpjglo} = 20 \times \text{\np{nn_GYRE}{nn\_GYRE}} + 2 + 2 \times \text{\np{nn_hls}{nn\_hls}} 
     251\end{align*} 
    252252 
    253253Obviously, the namelist parameters have to be adjusted to the chosen resolution, 
    254254see the Configurations pages on the \NEMO\ web site (\NEMO\ Configurations). 
    255255In the vertical, GYRE uses the default 30 ocean levels (\jp{jpk}\forcode{ = 31}) (\autoref{fig:DOM_zgr_e3}). 
     256 
     257\begin{listing} 
     258  \begin{forlines} 
     259!----------------------------------------------------------------------- 
     260&namusr_def    !   GYRE user defined namelist   
     261!----------------------------------------------------------------------- 
     262   nn_GYRE     =     1     !  GYRE resolution [1/degrees] 
     263   ln_bench    = .false.   !  ! =T benchmark with gyre: the gridsize is kept constant 
     264   jpkglo      =    31     !  number of model levels 
     265/ 
     266  \end{forlines} 
     267  \caption{\forcode{&namusr_def}} 
     268  \label{lst:namusr_def} 
     269\end{listing} 
    256270 
    257271The GYRE configuration is also used in benchmark test as it is very simple to increase its resolution and 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_model_basics_zstar.tex

    r14113 r14200  
    9595which imposes a very small time step when an explicit time stepping is used. 
    9696Two methods are proposed to allow a longer time step for the three-dimensional equations: 
    97 the filtered free surface, which is a modification of the continuous equations %(see \autoref{eq:MB_flt?}), 
     97the filtered free surface, which is a modification of the continuous equations \iffalse (see \autoref{eq:MB_flt?}) \fi , 
    9898and the split-explicit free surface described below. 
    9999The extra term introduced in the filtered method is calculated implicitly, 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/SI3/namelists/namdyn_adv

    r11703 r14200  
    22&namdyn_adv     !   Ice advection 
    33!------------------------------------------------------------------------------ 
    4    ln_adv_Pra       = .true.         !  Advection scheme (Prather) 
    5    ln_adv_UMx       = .false.          !  Advection scheme (Ultimate-Macho) 
     4   ln_adv_Pra       = .true.          !  Advection scheme (Prather) 
     5   ln_adv_UMx       = .false.         !  Advection scheme (Ultimate-Macho) 
    66      nn_UMx        =   5             !     order of the scheme for UMx (1-5 ; 20=centered 2nd order) 
    77/ 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/SI3/namelists/namsbc

    r11026 r14200  
    33!------------------------------------------------------------------------------ 
    44   rn_cio           =   5.0e-03       !  ice-ocean drag coefficient (-) 
    5    rn_blow_s        =   0.66          !  mesure of snow blowing into the leads 
     5   nn_snwfra        =   2             !  calculate the fraction of ice covered by snow (for zdf and albedo) 
     6                                      !     = 0  fraction = 1 (if snow) or 0 (if no snow) 
     7                                      !     = 1  fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation] 
     8                                      !     = 2  fraction = hsnw / (hsnw+0.02)    [CICE formulation] 
     9   rn_snwblow       =   0.66          !  mesure of snow blowing into the leads 
    610                                      !     = 1 => no snow blowing, < 1 => some snow blowing 
    711   nn_flxdist       =  -1             !  Redistribute heat flux over ice categories 
    … …  
    1216   ln_cndflx        = .false.         !  Use conduction flux as surface boundary conditions (i.e. for Jules coupling) 
    1317      ln_cndemulate = .false.         !     emulate conduction flux (if not provided in the inputs) 
     18   nn_qtrice        =   1             !  Solar flux transmitted thru the surface scattering layer: 
     19                                      !     = 0  Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)  
     20                                      !     = 1  Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities) 
    1421/ 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/ICE/icedyn_rhg_eap.F90

    r14072 r14200  
    1616   !!                                           CICE code (Tsamados, Heorton) 
    1717   !!---------------------------------------------------------------------- 
    18 #if defined key_si3 && ! defined key_agrif 
     18#if defined key_si3 
    1919   !!---------------------------------------------------------------------- 
    2020   !!   'key_si3'                                       SI3 sea-ice model 
    … …  
    6666   INTEGER ::   ncvgid   ! netcdf file id 
    6767   INTEGER ::   nvarid   ! netcdf variable id 
    68    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zmsk00, zmsk15 
     68   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   aimsk00 
     69   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   eap_res  , aimsk15 
    6970   !!---------------------------------------------------------------------- 
    7071   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    202203      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_rhg_eap: EAP sea-ice rheology' 
    203204      ! 
    204       ! for diagnostics and convergence tests 
    205       ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 
     205      IF( kt == nit000 )  THEN  
     206         ! 
     207         ! for diagnostics  
     208         ALLOCATE( aimsk00(jpi,jpj) ) 
     209         ! for convergence tests 
     210         IF( nn_rhg_chkcvg > 0 ) ALLOCATE( eap_res(jpi,jpj), aimsk15(jpi,jpj) ) 
     211      ENDIF 
     212      ! 
    206213      DO_2D( 1, 1, 1, 1 ) 
    207          zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    208          zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     214         aimsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    209215      END_2D 
     216      IF( nn_rhg_chkcvg > 0 ) THEN 
     217         DO_2D( 1, 1, 1, 1 ) 
     218            aimsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     219         END_2D 
     220      ENDIF 
    210221      ! 
    211222!!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization.... 
    … …  
    349360            zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    350361            ! ice-bottom stress at U points 
    351             zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) 
     362            zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 
    352363            ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
    353364            ! ice-bottom stress at V points 
    354             zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) 
     365            zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 
    355366            ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
    356367            ! ice_bottom stress at T points 
    357             zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) 
     368            zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) )    ! if grounded icebergs are read: ocean depth = 0 
    358369            tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    359370         END_2D 
    … …  
    749760 
    750761         ! convergence test 
    751          IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 
     762         IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg_eap( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 
    752763         ! 
    753764         !                                                ! ==================== ! 
    … …  
    819830            &                                  ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
    820831         ! 
    821          CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) 
    822          CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 ) 
    823          CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 ) 
    824          CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 ) 
    825          CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 ) 
    826          CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 ) 
     832         CALL iom_put( 'utau_oi' , ztaux_oi * aimsk00 ) 
     833         CALL iom_put( 'vtau_oi' , ztauy_oi * aimsk00 ) 
     834         CALL iom_put( 'utau_ai' , ztaux_ai * aimsk00 ) 
     835         CALL iom_put( 'vtau_ai' , ztauy_ai * aimsk00 ) 
     836         CALL iom_put( 'utau_bi' , ztaux_bi * aimsk00 ) 
     837         CALL iom_put( 'vtau_bi' , ztauy_bi * aimsk00 ) 
    827838      ENDIF 
    828839 
    829840      ! --- divergence, shear and strength --- ! 
    830       IF( iom_use('icediv') )   CALL iom_put( 'icediv' , pdivu_i  * zmsk00 )   ! divergence 
    831       IF( iom_use('iceshe') )   CALL iom_put( 'iceshe' , pshear_i * zmsk00 )   ! shear 
    832       IF( iom_use('icedlt') )   CALL iom_put( 'icedlt' , pdelta_i * zmsk00 )   ! delta 
    833       IF( iom_use('icestr') )   CALL iom_put( 'icestr' , strength * zmsk00 )   ! strength 
     841      IF( iom_use('icediv') )   CALL iom_put( 'icediv' , pdivu_i  * aimsk00 )   ! divergence 
     842      IF( iom_use('iceshe') )   CALL iom_put( 'iceshe' , pshear_i * aimsk00 )   ! shear 
     843      IF( iom_use('icedlt') )   CALL iom_put( 'icedlt' , pdelta_i * aimsk00 )   ! delta 
     844      IF( iom_use('icestr') )   CALL iom_put( 'icestr' , strength * aimsk00 )   ! strength 
    834845 
    835846      ! --- Stress tensor invariants (SIMIP diags) --- ! 
    … …  
    856867         ! 
    857868         ! Stress tensor invariants (normal and shear stress N/m) - SIMIP diags - definitions following Coon (1974) and Feltham (2008) 
    858          IF( iom_use('normstr') )   CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress 
    859          IF( iom_use('sheastr') )   CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress 
     869         IF( iom_use('normstr') )   CALL iom_put( 'normstr', zsig_I (:,:) * aimsk00(:,:) ) ! Normal stress 
     870         IF( iom_use('sheastr') )   CALL iom_put( 'sheastr', zsig_II(:,:) * aimsk00(:,:) ) ! Maximum shear stress 
    860871 
    861872         DEALLOCATE ( zsig_I, zsig_II ) 
    … …  
    903914         CALL lbc_lnk_multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 
    904915 
    905          CALL iom_put( 'yield11', zyield11 * zmsk00 ) 
    906          CALL iom_put( 'yield22', zyield22 * zmsk00 ) 
    907          CALL iom_put( 'yield12', zyield12 * zmsk00 ) 
     916         CALL iom_put( 'yield11', zyield11 * aimsk00 ) 
     917         CALL iom_put( 'yield22', zyield22 * aimsk00 ) 
     918         CALL iom_put( 'yield12', zyield12 * aimsk00 ) 
    908919      ENDIF 
    909920 
    … …  
    911922      IF( iom_use('aniso') ) THEN 
    912923         CALL lbc_lnk( 'icedyn_rhg_eap', paniso_11, 'T', 1.0_wp ) 
    913          CALL iom_put( 'aniso' , paniso_11 * zmsk00 ) 
     924         CALL iom_put( 'aniso' , paniso_11 * aimsk00 ) 
    914925      ENDIF 
    915926 
    … …  
    922933            &                                    zfU, 'U', -1.0_wp,   zfV, 'V', -1.0_wp ) 
    923934 
    924          CALL iom_put( 'dssh_dx' , zspgU * zmsk00 )   ! Sea-surface tilt term in force balance (x) 
    925          CALL iom_put( 'dssh_dy' , zspgV * zmsk00 )   ! Sea-surface tilt term in force balance (y) 
    926          CALL iom_put( 'corstrx' , zCorU * zmsk00 )   ! Coriolis force term in force balance (x) 
    927          CALL iom_put( 'corstry' , zCorV * zmsk00 )   ! Coriolis force term in force balance (y) 
    928          CALL iom_put( 'intstrx' , zfU   * zmsk00 )   ! Internal force term in force balance (x) 
    929          CALL iom_put( 'intstry' , zfV   * zmsk00 )   ! Internal force term in force balance (y) 
     935         CALL iom_put( 'dssh_dx' , zspgU * aimsk00 )   ! Sea-surface tilt term in force balance (x) 
     936         CALL iom_put( 'dssh_dy' , zspgV * aimsk00 )   ! Sea-surface tilt term in force balance (y) 
     937         CALL iom_put( 'corstrx' , zCorU * aimsk00 )   ! Coriolis force term in force balance (x) 
     938         CALL iom_put( 'corstry' , zCorV * aimsk00 )   ! Coriolis force term in force balance (y) 
     939         CALL iom_put( 'intstrx' , zfU   * aimsk00 )   ! Internal force term in force balance (x) 
     940         CALL iom_put( 'intstry' , zfV   * aimsk00 )   ! Internal force term in force balance (y) 
    930941      ENDIF 
    931942 
    … …  
    938949         DO_2D( 0, 0, 0, 0 ) 
    939950            ! 2D ice mass, snow mass, area transport arrays (X, Y) 
    940             zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
    941             zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
     951            zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * aimsk00(ji,jj) 
     952            zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * aimsk00(ji,jj) 
    942953 
    943954            zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
    … …  
    973984            IF( ln_aEVP ) THEN   ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
    974985               CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & 
    975                   &                           ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     986                  &                           ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * aimsk15(:,:) ) 
    976987            ELSE                 ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
    977988               CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & 
    978                   &                                             ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     989                  &                                             ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * aimsk15(:,:) ) 
    979990            ENDIF 
    980991         ENDIF 
    981992      ENDIF 
    982993      ! 
    983       DEALLOCATE( zmsk00, zmsk15 ) 
    984       ! 
    985994   END SUBROUTINE ice_dyn_rhg_eap 
    986995 
    987996 
    988    SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb ) 
     997   SUBROUTINE rhg_cvg_eap( kt, kiter, kitermax, pu, pv, pub, pvb ) 
    989998      !!---------------------------------------------------------------------- 
    990       !!                    ***  ROUTINE rhg_cvg  *** 
     999      !!                    ***  ROUTINE rhg_cvg_eap  *** 
    9911000      !! 
    9921001      !! ** Purpose :   check convergence of oce rheology 
    … …  
    10061015      REAL(wp)          ::   zresm           ! local real 
    10071016      CHARACTER(len=20) ::   clname 
    1008       REAL(wp), DIMENSION(jpi,jpj) ::   zres           ! check convergence 
    10091017      !!---------------------------------------------------------------------- 
    10101018 
    … …  
    10141022         IF( lwp ) THEN 
    10151023            WRITE(numout,*) 
    1016             WRITE(numout,*) 'rhg_cvg : ice rheology convergence control' 
     1024            WRITE(numout,*) 'rhg_cvg_eap : ice rheology convergence control' 
    10171025            WRITE(numout,*) '~~~~~~~' 
    10181026         ENDIF 
    … …  
    10371045      ELSE 
    10381046         DO_2D( 1, 1, 1, 1 ) 
    1039             zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
    1040                &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 
     1047            eap_res(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
     1048               &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * aimsk15(ji,jj) 
    10411049         END_2D 
    1042          zresm = MAXVAL( zres ) 
     1050 
     1051         zresm = MAXVAL( eap_res ) 
    10431052         CALL mpp_max( 'icedyn_rhg_evp', zresm )   ! max over the global domain 
    10441053      ENDIF 
    … …  
    10511060      ENDIF 
    10521061 
    1053    END SUBROUTINE rhg_cvg 
     1062   END SUBROUTINE rhg_cvg_eap 
    10541063 
    10551064 
    … …  
    10801089      REAL(wp) ::   zsig11, zsig12, zsig22 
    10811090      REAL(wp) ::   zsgprm11, zsgprm12, zsgprm22 
    1082       REAL(wp) ::   zinvstressconviso 
    10831091      REAL(wp) ::   zAngle_denom_gamma,  zAngle_denom_alpha 
    10841092      REAL(wp) ::   zTany_1, zTany_2 
    1085       REAL(wp) ::   zx, zy, zdx, zdy, zda, zkxw, kyw, kaw 
     1093      REAL(wp) ::   zx, zy, zkxw, kyw, kaw 
    10861094      REAL(wp) ::   zinvdx, zinvdy, zinvda 
    1087       REAL(wp) ::   zdtemp1, zdtemp2, zatempprime, zinvsin 
    1088  
    1089       REAL(wp), PARAMETER ::   kfriction = 0.45_wp 
    1090       !!--------------------------------------------------------------------- 
     1095      REAL(wp) ::   zdtemp1, zdtemp2, zatempprime 
     1096 
     1097      REAL(wp), PARAMETER ::   ppkfriction = 0.45_wp 
    10911098      ! Factor to maintain the same stress as in EVP (see Section 3) 
    10921099      ! Can be set to 1 otherwise 
    1093 !      zinvstressconviso = 1._wp/(1._wp+kfriction*kfriction) 
    1094       zinvstressconviso = 1._wp 
    1095  
    1096       zinvsin = 1._wp/sin(2._wp*pphi) * zinvstressconviso 
    1097       !now uses phi as set in higher code 
     1100!     REAL(wp), PARAMETER ::   ppinvstressconviso = 1._wp/(1._wp+ppkfriction*ppkfriction) 
     1101      REAL(wp), PARAMETER ::   ppinvstressconviso = 1._wp 
     1102 
     1103      ! next statement uses pphi set in main module (icedyn_rhg_eap) 
     1104      REAL(wp), PARAMETER ::   ppinvsin = 1._wp/sin(2._wp*pphi) * ppinvstressconviso 
    10981105 
    10991106      ! compute eigenvalues, eigenvectors and angles for structure tensor, strain 
    … …  
    11751182 
    11761183      ! 3) update anisotropic stress tensor 
    1177       zdx   = rpi/real(nx_yield-1,kind=wp) 
    1178       zdy   = rpi/real(ny_yield-1,kind=wp) 
    1179       zda   = 0.5_wp/real(na_yield-1,kind=wp) 
    1180       zinvdx = 1._wp/zdx 
    1181       zinvdy = 1._wp/zdy 
    1182       zinvda = 1._wp/zda 
     1184      zinvdx = real(nx_yield-1,kind=wp)/rpi 
     1185      zinvdy = real(ny_yield-1,kind=wp)/rpi 
     1186      zinvda = 2._wp*real(na_yield-1,kind=wp) 
    11831187 
    11841188      ! % need 8 coords and 8 weights 
    … …  
    12581262      ! Tsamados 2013) 
    12591263 
    1260       zsig11  = pstrength*(zstemp11r + kfriction*zstemp11s) * zinvsin 
    1261       zsig12  = pstrength*(zstemp12r + kfriction*zstemp12s) * zinvsin 
    1262       zsig22  = pstrength*(zstemp22r + kfriction*zstemp22s) * zinvsin 
     1264      zsig11  = pstrength*(zstemp11r + ppkfriction*zstemp11s) * ppinvsin 
     1265      zsig12  = pstrength*(zstemp12r + ppkfriction*zstemp12s) * ppinvsin 
     1266      zsig22  = pstrength*(zstemp22r + ppkfriction*zstemp22s) * ppinvsin 
    12631267 
    12641268      ! Back - rotation of the stress from principal axes into general coordinates 
    … …  
    13191323      REAL (wp) ::   zQ11, zQ12, zQ11Q11, zQ11Q12, zQ12Q12 
    13201324 
    1321 !!$      REAL (wp), PARAMETER ::   kfrac = 0.0001_wp   ! rate of fracture formation 
    1322       REAL (wp), PARAMETER ::   kfrac = 1.e-3_wp   ! rate of fracture formation 
    1323       REAL (wp), PARAMETER ::   threshold = 0.3_wp  ! critical confinement ratio 
     1325!!$   REAL (wp), PARAMETER ::   ppkfrac = 0.0001_wp   ! rate of fracture formation 
     1326      REAL (wp), PARAMETER ::   ppkfrac = 1.e-3_wp    ! rate of fracture formation 
     1327      REAL (wp), PARAMETER ::   ppthreshold = 0.3_wp  ! critical confinement ratio 
    13241328      !!--------------------------------------------------------------- 
    13251329      ! 
    … …  
    13631367      ! which leads to the loss of their shape, so we again model it through diffusion 
    13641368      ELSEIF ((zsigma_1 >= 0.0_wp).AND.(zsigma_2 < 0.0_wp))  THEN 
    1365          pmresult11 = - kfrac * (pa11 - zQ12Q12) 
    1366          pmresult12 = - kfrac * (pa12 + zQ11Q12) 
     1369         pmresult11 = - ppkfrac * (pa11 - zQ12Q12) 
     1370         pmresult12 = - ppkfrac * (pa12 + zQ11Q12) 
    13671371 
    13681372      ! Shear faulting 
    … …  
    13701374         pmresult11 = 0.0_wp 
    13711375         pmresult12 = 0.0_wp 
    1372       ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= threshold)) THEN 
    1373          pmresult11 = - kfrac * (pa11 - zQ12Q12) 
    1374          pmresult12 = - kfrac * (pa12 + zQ11Q12) 
     1376      ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= ppthreshold)) THEN 
     1377         pmresult11 = - ppkfrac * (pa11 - zQ12Q12) 
     1378         pmresult12 = - ppkfrac * (pa12 + zQ11Q12) 
    13751379 
    13761380      ! Horizontal spalling 
    … …  
    14051409      !!clem 
    14061410      REAL(wp) ::   zw1, zw2, zfac, ztemp 
    1407       REAL(wp) ::   idx, idy, idz 
     1411      REAL(wp) ::   zidx, zidy, zidz 
     1412      REAL(wp) ::   zsaak(6)                  ! temporary array 
    14081413 
    14091414      REAL(wp), PARAMETER           ::   eps6 = 1.0e-6_wp 
    … …  
    15221527            zw2 = w2(ainit+ia*da) 
    15231528            DO iz = 1, nz 
    1524                idz = zinit+iz*dz 
     1529               zidz = zinit+iz*dz 
    15251530               ztemp = zw1 * EXP(-zw2*(zinit+iz*dz)*(zinit+iz*dz)) 
    15261531               DO iy = 1, ny_yield 
    1527                   idy = yinit+iy*dy 
     1532                  zidy = yinit+iy*dy 
    15281533                  DO ix = 1, nx_yield 
    1529                      idx = xinit+ix*dx 
    1530                      s11r(ix,iy,ia) = s11r(ix,iy,ia) + ztemp * s11kr(idx,idy,idz)*zfac 
    1531                      s12r(ix,iy,ia) = s12r(ix,iy,ia) + ztemp * s12kr(idx,idy,idz)*zfac 
    1532                      s22r(ix,iy,ia) = s22r(ix,iy,ia) + ztemp * s22kr(idx,idy,idz)*zfac 
    1533                      s11s(ix,iy,ia) = s11s(ix,iy,ia) + ztemp * s11ks(idx,idy,idz)*zfac 
    1534                      s12s(ix,iy,ia) = s12s(ix,iy,ia) + ztemp * s12ks(idx,idy,idz)*zfac 
    1535                      s22s(ix,iy,ia) = s22s(ix,iy,ia) + ztemp * s22ks(idx,idy,idz)*zfac 
     1534                     zidx = xinit+ix*dx 
     1535                     call all_skr_sks(zidx,zidy,zidz,zsaak) 
     1536                     zsaak = ztemp*zsaak*zfac 
     1537                     s11r(ix,iy,ia) = s11r(ix,iy,ia) + zsaak(1) 
     1538                     s12r(ix,iy,ia) = s12r(ix,iy,ia) + zsaak(2) 
     1539                     s22r(ix,iy,ia) = s22r(ix,iy,ia) + zsaak(3) 
     1540                     s11s(ix,iy,ia) = s11s(ix,iy,ia) + zsaak(4) 
     1541                     s12s(ix,iy,ia) = s12s(ix,iy,ia) + zsaak(5) 
     1542                     s22s(ix,iy,ia) = s22s(ix,iy,ia) + zsaak(6) 
    15361543                  END DO 
    15371544               END DO 
    15381545            END DO 
    15391546         END DO 
    1540  
    15411547         zfac = 1._wp/sin(2._wp*pphi) 
    15421548         ia = na_yield 
    15431549         DO iy = 1, ny_yield 
    1544             idy = yinit+iy*dy 
     1550            zidy = yinit+iy*dy 
    15451551            DO ix = 1, nx_yield 
    1546                idx = xinit+ix*dx 
    1547                s11r(ix,iy,ia) = 0.5_wp*s11kr(idx,idy,0._wp)*zfac 
    1548                s12r(ix,iy,ia) = 0.5_wp*s12kr(idx,idy,0._wp)*zfac 
    1549                s22r(ix,iy,ia) = 0.5_wp*s22kr(idx,idy,0._wp)*zfac 
    1550                s11s(ix,iy,ia) = 0.5_wp*s11ks(idx,idy,0._wp)*zfac 
    1551                s12s(ix,iy,ia) = 0.5_wp*s12ks(idx,idy,0._wp)*zfac 
    1552                s22s(ix,iy,ia) = 0.5_wp*s22ks(idx,idy,0._wp)*zfac 
     1552               zidx = xinit+ix*dx 
     1553               call all_skr_sks(zidx,zidy,0._wp,zsaak) 
     1554               zsaak = 0.5_wp*zsaak*zfac 
     1555               s11r(ix,iy,ia) = zsaak(1) 
     1556               s12r(ix,iy,ia) = zsaak(2) 
     1557               s22r(ix,iy,ia) = zsaak(3) 
     1558               s11s(ix,iy,ia) = zsaak(4) 
     1559               s12s(ix,iy,ia) = zsaak(5) 
     1560               s22s(ix,iy,ia) = zsaak(6) 
    15531561            ENDDO 
    15541562         ENDDO 
    … …  
    16161624   END FUNCTION w2 
    16171625 
    1618    FUNCTION s11kr(px,py,pz) 
    1619       !!------------------------------------------------------------------- 
    1620       !! Function : s11kr 
    1621       !!------------------------------------------------------------------- 
     1626   SUBROUTINE all_skr_sks( px, py, pz, allsk ) 
    16221627      REAL(wp), INTENT(in   ) ::   px,py,pz 
    1623  
    1624       REAL(wp) ::   s11kr, zpih 
    1625  
     1628      REAL(wp), INTENT(out  ) ::   allsk(6) 
     1629 
     1630      REAL(wp) ::   zs12r0, zs21r0 
     1631      REAL(wp) ::   zs12s0, zs21s0 
     1632 
     1633      REAL(wp) ::   zpih 
    16261634      REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    16271635      REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    … …  
    16731681      ENDIF 
    16741682 
    1675       s11kr = (- zHen1t2 * zn1t2i11 - zHen2t1 * zn2t1i11) 
    1676  
    1677    END FUNCTION s11kr 
    1678  
    1679    FUNCTION s12kr(px,py,pz) 
     1683      !!------------------------------------------------------------------- 
     1684      !! Function : s11kr 
     1685      !!------------------------------------------------------------------- 
     1686      allsk(1) = (- zHen1t2 * zn1t2i11 - zHen2t1 * zn2t1i11) 
    16801687      !!------------------------------------------------------------------- 
    16811688      !! Function : s12kr 
    16821689      !!------------------------------------------------------------------- 
    1683       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1684  
    1685       REAL(wp) ::   s12kr, zs12r0, zs21r0, zpih 
    1686  
    1687       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1688       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1689       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1690       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1691       REAL(wp) ::   zd11, zd12, zd22 
    1692       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1693       REAL(wp) ::   zHen1t2, zHen2t1 
    1694       !!------------------------------------------------------------------- 
    1695       zpih = 0.5_wp*rpi 
    1696  
    1697       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1698       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1699       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1700       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1701       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1702       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1703       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1704       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1705       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1706       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1707       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1708       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1709       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1710       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1711       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1712       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1713       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1714       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1715       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1716       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1717       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1718       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1719  
    1720       IF (-zIIn1t2>=rsmall) THEN 
    1721       zHen1t2 = 1._wp 
    1722       ELSE 
    1723       zHen1t2 = 0._wp 
    1724       ENDIF 
    1725  
    1726       IF (-zIIn2t1>=rsmall) THEN 
    1727       zHen2t1 = 1._wp 
    1728       ELSE 
    1729       zHen2t1 = 0._wp 
    1730       ENDIF 
    1731  
    17321690      zs12r0 = (- zHen1t2 * zn1t2i12 - zHen2t1 * zn2t1i12) 
    17331691      zs21r0 = (- zHen1t2 * zn1t2i21 - zHen2t1 * zn2t1i21) 
    1734       s12kr=0.5_wp*(zs12r0+zs21r0) 
    1735  
    1736    END FUNCTION s12kr 
    1737  
    1738    FUNCTION s22kr(px,py,pz) 
     1692      allsk(2)=0.5_wp*(zs12r0+zs21r0) 
    17391693      !!------------------------------------------------------------------- 
    17401694      !! Function : s22kr 
    17411695      !!------------------------------------------------------------------- 
    1742       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1743  
    1744       REAL(wp) ::   s22kr, zpih 
    1745  
    1746       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1747       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1748       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1749       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1750       REAL(wp) ::   zd11, zd12, zd22 
    1751       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1752       REAL(wp) ::   zHen1t2, zHen2t1 
    1753       !!------------------------------------------------------------------- 
    1754       zpih = 0.5_wp*rpi 
    1755  
    1756       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1757       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1758       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1759       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1760       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1761       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1762       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1763       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1764       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1765       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1766       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1767       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1768       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1769       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1770       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1771       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1772       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1773       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1774       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1775       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1776       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1777       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1778  
    1779       IF (-zIIn1t2>=rsmall) THEN 
    1780       zHen1t2 = 1._wp 
    1781       ELSE 
    1782       zHen1t2 = 0._wp 
    1783       ENDIF 
    1784  
    1785       IF (-zIIn2t1>=rsmall) THEN 
    1786       zHen2t1 = 1._wp 
    1787       ELSE 
    1788       zHen2t1 = 0._wp 
    1789       ENDIF 
    1790  
    1791       s22kr = (- zHen1t2 * zn1t2i22 - zHen2t1 * zn2t1i22) 
    1792  
    1793    END FUNCTION s22kr 
    1794  
    1795    FUNCTION s11ks(px,py,pz) 
     1696      allsk(3) = (- zHen1t2 * zn1t2i22 - zHen2t1 * zn2t1i22) 
    17961697      !!------------------------------------------------------------------- 
    17971698      !! Function : s11ks 
    17981699      !!------------------------------------------------------------------- 
    1799       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1800  
    1801       REAL(wp) ::   s11ks, zpih 
    1802  
    1803       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1804       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1805       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1806       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1807       REAL(wp) ::   zd11, zd12, zd22 
    1808       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1809       REAL(wp) ::   zHen1t2, zHen2t1 
    1810       !!------------------------------------------------------------------- 
    1811       zpih = 0.5_wp*rpi 
    1812  
    1813       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1814       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1815       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1816       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1817       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1818       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1819       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1820       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1821       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1822       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1823       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1824       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1825       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1826       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1827       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1828       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1829       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1830       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1831       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1832       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1833       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1834       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1835  
    1836       IF (-zIIn1t2>=rsmall) THEN 
    1837       zHen1t2 = 1._wp 
    1838       ELSE 
    1839       zHen1t2 = 0._wp 
    1840       ENDIF 
    1841  
    1842       IF (-zIIn2t1>=rsmall) THEN 
    1843       zHen2t1 = 1._wp 
    1844       ELSE 
    1845       zHen2t1 = 0._wp 
    1846       ENDIF 
    1847  
    1848       s11ks = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i11 + zHen2t1 * zt2t1i11) 
    1849  
    1850    END FUNCTION s11ks 
    1851  
    1852    FUNCTION s12ks(px,py,pz) 
     1700 
     1701      allsk(4) = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i11 + zHen2t1 * zt2t1i11) 
    18531702      !!------------------------------------------------------------------- 
    18541703      !! Function : s12ks 
    18551704      !!------------------------------------------------------------------- 
    1856       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1857  
    1858       REAL(wp) ::   s12ks, zs12s0, zs21s0, zpih 
    1859  
    1860       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1861       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1862       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1863       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1864       REAL(wp) ::   zd11, zd12, zd22 
    1865       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1866       REAL(wp) ::   zHen1t2, zHen2t1 
    1867       !!------------------------------------------------------------------- 
    1868       zpih = 0.5_wp*rpi 
    1869  
    1870       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1871       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1872       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1873       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1874       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1875       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1876       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1877       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1878       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1879       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1880       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1881       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1882       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1883       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1884       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1885       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1886       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1887       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1888       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1889       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1890       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1891       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1892  
    1893       IF (-zIIn1t2>=rsmall) THEN 
    1894       zHen1t2 = 1._wp 
    1895       ELSE 
    1896       zHen1t2 = 0._wp 
    1897       ENDIF 
    1898  
    1899       IF (-zIIn2t1>=rsmall) THEN 
    1900       zHen2t1 = 1._wp 
    1901       ELSE 
    1902       zHen2t1 = 0._wp 
    1903       ENDIF 
    1904  
    19051705      zs12s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i12 + zHen2t1 * zt2t1i12) 
    19061706      zs21s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i21 + zHen2t1 * zt2t1i21) 
    1907       s12ks=0.5_wp*(zs12s0+zs21s0) 
    1908  
    1909    END FUNCTION s12ks 
    1910  
    1911    FUNCTION s22ks(px,py,pz) 
     1707      allsk(5)=0.5_wp*(zs12s0+zs21s0) 
    19121708      !!------------------------------------------------------------------- 
    19131709      !! Function : s22ks 
    19141710      !!------------------------------------------------------------------- 
    1915       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1916  
    1917       REAL(wp) ::   s22ks, zpih 
    1918  
    1919       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1920       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1921       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1922       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1923       REAL(wp) ::   zd11, zd12, zd22 
    1924       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1925       REAL(wp) ::   zHen1t2, zHen2t1 
    1926       !!------------------------------------------------------------------- 
    1927       zpih = 0.5_wp*rpi 
    1928  
    1929       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1930       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1931       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1932       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1933       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1934       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1935       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1936       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1937       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1938       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1939       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1940       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1941       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1942       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1943       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1944       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1945       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1946       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1947       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1948       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1949       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1950       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1951  
    1952       IF (-zIIn1t2>=rsmall) THEN 
    1953       zHen1t2 = 1._wp 
    1954       ELSE 
    1955       zHen1t2 = 0._wp 
    1956       ENDIF 
    1957  
    1958       IF (-zIIn2t1>=rsmall) THEN 
    1959       zHen2t1 = 1._wp 
    1960       ELSE 
    1961       zHen2t1 = 0._wp 
    1962       ENDIF 
    1963  
    1964       s22ks = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i22 + zHen2t1 * zt2t1i22) 
    1965  
    1966    END FUNCTION s22ks 
     1711      allsk(6) = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i22 + zHen2t1 * zt2t1i22) 
     1712   END SUBROUTINE all_skr_sks 
    19671713 
    19681714#else 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/ICE/iceistate.F90

    r14086 r14200  
    2222   USE eosbn2         ! equation of state 
    2323# if defined key_qco 
    24    USE domqco         ! Variable volume 
     24   USE domqco         ! Quasi-Eulerian coord. 
     25# elif defined key_linssh 
     26   !                  ! Fix in time coord. 
    2527# else 
    2628   USE domvvl         ! Variable volume 
    … …  
    424426         ! 
    425427#if defined key_qco 
    426          IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm )        ! interpolation scale factor, depth and water column 
     428         IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm )        ! upadte of r3=ssh/h0 ratios 
     429#elif defined key_linssh 
     430         !                                                          ! fix in time coord. : no update of vertical coord. 
    427431#else 
    428432         IF( .NOT.ln_linssh )   CALL dom_vvl_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_ice_interp.F90

    r14086 r14200  
    6969      Agrif_UseSpecialValue = .FALSE. 
    7070      ! lbc ???? 
    71       ! JC: do we really need the 3 lines below ? 
     71      ! 
    7272      CALL ice_var_glo2eqv 
    73       CALL ice_var_zapsmall 
    74       CALL ice_var_agg(2) 
    75  
    76       ! Melt ponds 
    77       WHERE( a_i > epsi10 ) 
    78          a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 
    79       ELSEWHERE 
    80          a_ip_frac(:,:,:) = 0._wp 
    81       END WHERE 
    82       WHERE( a_ip > 0._wp )       ! ???????     
    83          h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) 
    84       ELSEWHERE 
    85          h_ip(:,:,:) = 0._wp 
    86       END WHERE    
    87  
    88       tn_ice(:,:,:) = t_su(:,:,:) 
    89       t1_ice(:,:,:) = t_i (:,:,1,:)  
    90  
     73      ! 
    9174   END SUBROUTINE agrif_istate_ice 
    9275 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_interp.F90

    r14086 r14200  
    7676      IF(lwp) WRITE(numout,*) ' ' 
    7777 
    78       IF ( ln_rstart ) &  
    79          & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 
    80  
    8178      IF ( .NOT.Agrif_Parent(l_1st_euler) ) &  
    8279         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 
    … …  
    8683      Agrif_UseSpecialValue = .TRUE. 
    8784 
    88       ts(:,:,:,:,:) = 0.0_wp 
    89       uu(:,:,:,:)   = 0.0_wp 
    90       vv(:,:,:,:)   = 0.0_wp  
    91       ssh(:,:,:)    = 0._wp 
     85      ts(:,:,:,:,Kbb) = 0.0_wp 
     86      uu(:,:,:,Kbb)   = 0.0_wp 
     87      vv(:,:,:,Kbb)   = 0.0_wp  
    9288        
    9389      Krhs_a = Kbb   ;   Kmm_a = Kbb 
    9490 
    9591      CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 
    96       CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 
    9792 
    9893      Agrif_UseSpecialValue = ln_spc_dyn 
    … …  
    108103      Krhs_a = Kaa   ;   Kmm_a = Kmm 
    109104 
    110       ssh(:,:,Kbb) = ssh(:,:,Kbb) * tmask(:,:,1) 
    111  
    112105      DO jn = 1, jpts 
    113106         ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:) 
    … …  
    118111      CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 
    119112      CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T',  1.0_wp ) 
    120       CALL lbc_lnk( 'agrif_istate_oce', ssh(:,:,Kbb), 'T', 1.0_wp ) 
    121113 
    122114   END SUBROUTINE Agrif_istate_oce 
    123115 
    124116 
    125    SUBROUTINE Agrif_istate_ssh( Kbb, Kmm ) 
     117   SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa ) 
    126118      !!---------------------------------------------------------------------- 
    127119      !!                 *** ROUTINE agrif_istate_ssh *** 
    … …  
    132124      IMPLICIT NONE 
    133125      ! 
    134       INTEGER, INTENT(in)  :: Kbb, Kmm  
     126      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa  
    135127      !!---------------------------------------------------------------------- 
    136128      IF(lwp) WRITE(numout,*) ' ' 
    … …  
    139131      IF(lwp) WRITE(numout,*) ' ' 
    140132 
    141       IF ( ln_rstart ) &  
    142          & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 
    143  
    144133      IF ( .NOT.Agrif_Parent(l_1st_euler) ) &  
    145134         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 
    146135 
    147       Kmm_a = Kmm 
    148       ssh(:,:,Kmm) = 0._wp 
    149  
     136      Krhs_a = Kbb   ;   Kmm_a = Kbb 
     137      ! 
    150138      Agrif_SpecialValue    = 0._wp 
    151139      Agrif_UseSpecialValue = .TRUE. 
    152140      l_ini_child           = .TRUE. 
    153141      ! 
     142      ssh(:,:,Kbb) = 0._wp 
    154143      CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 
    155144      ! 
    156145      Agrif_UseSpecialValue = .FALSE. 
    157146      l_ini_child           = .FALSE. 
    158       CALL lbc_lnk( 'dom_vvl_rst', ssh(:,:,Kmm), 'T', 1._wp ) 
     147      ! 
     148      Krhs_a = Kaa   ;   Kmm_a = Kmm 
     149      ! 
     150      CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp ) 
     151      ! 
     152      ssh(:,:,Kmm) = ssh(:,:,Kbb) 
     153      ssh(:,:,Kaa) = 0._wp 
    159154 
    160155   END SUBROUTINE Agrif_istate_ssh 
    … …  
    203198 
    204199      IF( .NOT.ln_dynspg_ts ) THEN ! Get transports 
    205          ubdy(:,:) = 0._wp   ;   vbdy(:,:) = 0._wp  
     200         ubdy(:,:) = 0._wp    ;  vbdy(:,:) = 0._wp 
     201         utint_stage(:,:) = 0 ;  vtint_stage(:,:) = 0 
    206202         CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 
    207203         CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) 
    … …  
    274270         IF( .NOT.ln_dynspg_ts ) THEN  
    275271            DO ji = mi0(ibdy1), mi1(ibdy2) 
    276                uu_b(ji,:,Krhs_a) = 0._wp 
    277                DO jk = 1, jpkm1 
    278                   DO jj = 1, jpj 
    279                      uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    280                   END DO 
    281                END DO 
    282272               DO jj = 1, jpj 
    283273                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    … …  
    304294         ! 
    305295         ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()  
    306          ibdy2 = jpiglo - ( nn_hls + 1 )              ! 
     296         ibdy2 = jpiglo - ( nn_hls + 1 )      
     297         ! 
    307298         IF( .NOT.ln_dynspg_ts ) THEN  
    308299            DO ji = mi0(ibdy1), mi1(ibdy2) 
    309                vv_b(ji,:,Krhs_a) = 0._wp 
    310                DO jk = 1, jpkm1 
    311                   DO jj = 1, jpj 
    312                      vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    313                   END DO 
    314                END DO 
    315300               DO jj = 1, jpj 
    316301                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    … …  
    318303            END DO 
    319304         ENDIF 
    320  
     305         ! 
    321306         DO ji = mi0(ibdy1), mi1(ibdy2) 
    322307            zvb(ji,:) = 0._wp 
    … …  
    345330         IF( .NOT.ln_dynspg_ts ) THEN 
    346331            DO jj = mj0(jbdy1), mj1(jbdy2) 
    347                vv_b(:,jj,Krhs_a) = 0._wp 
    348                DO jk = 1, jpkm1 
    349                   DO ji = 1, jpi 
    350                      vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    351                   END DO 
    352                END DO 
    353                DO ji=1,jpi 
    354                   vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)  
    355                   uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 
     332               DO ji = 1, jpi 
     333                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 
     334                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    356335               END DO 
    357336            END DO 
    … …  
    401380         IF( .NOT.ln_dynspg_ts ) THEN 
    402381            DO jj = mj0(jbdy1), mj1(jbdy2) 
    403                vv_b(:,jj,Krhs_a) = 0._wp 
    404                DO jk = 1, jpkm1 
    405                   DO ji = 1, jpi 
    406                      vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    407                   END DO 
    408                END DO 
    409                DO ji=1,jpi 
     382               DO ji = 1, jpi 
    410383                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    411384               END DO 
    … …  
    432405         jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()   
    433406         jbdy2 = jpjglo - ( nn_hls + 1 ) 
     407         ! 
    434408         IF( .NOT.ln_dynspg_ts ) THEN 
    435409            DO jj = mj0(jbdy1), mj1(jbdy2) 
    436                uu_b(:,jj,Krhs_a) = 0._wp 
    437                DO jk = 1, jpkm1 
    438                   DO ji = 1, jpi 
    439                      uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    440                   END DO 
    441                END DO 
    442                DO ji=1,jpi 
     410               DO ji = 1, jpi 
    443411                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    444412               END DO 
    445413            END DO 
    446414         ENDIF 
    447  
     415         ! 
    448416         DO jj = mj0(jbdy1), mj1(jbdy2) 
    449417            zub(:,jj) = 0._wp 
    … …  
    651619      IF( ll_int_cons ) THEN  ! Conservative interpolation 
    652620         IF ( lk_tint2d_notinterp ) THEN 
     621            Agrif_UseSpecialValue = .FALSE. 
    653622            CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const ) 
    654623            CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const )  
    655624            ! Divergence conserving correction terms: 
    656             CALL Agrif_Bc_variable(    ub2b_cor_id, calledweight=1._wp, procname=        ub2b_cor ) 
    657             CALL Agrif_Bc_variable(    vb2b_cor_id, calledweight=1._wp, procname=        vb2b_cor ) 
     625            IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable(    ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor ) 
     626            IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable(    vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor ) 
    658627         ELSE 
    659628            ! order matters here !!!!!! 
    … …  
    990959      ELSE 
    991960         IF( l_ini_child ) THEN 
    992             ssh(i1:i2,j1:j2,Kmm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
     961            ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
    993962         ELSE 
    994963            hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
    … …  
    14381407         ptab(:,:) = 0._wp 
    14391408         DO ji=i1+1,i2-1 
    1440             DO jj=j1+1,j2 
     1409            DO jj=j1+1,j2-1 
    14411410               ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj  )*e1v(ji+1,jj  )   &  
    14421411                           &            -vb2_b(ji-1,jj  )*e1v(ji-1,jj  ) ) & 
    … …  
    15421511         ptab(:,:) = 0._wp 
    15431512         DO ji=i1+1,i2-1 
    1544             DO jj=j1+1,j2 
     1513            DO jj=j1+1,j2-1 
    15451514               ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji  ,jj+1)*e2u(ji  ,jj+1)   &  
    15461515                           &            -ub2_b(ji  ,jj-1)*e2u(ji  ,jj-1) ) & 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_sponge.F90

    r14086 r14200  
    441441                  N_in = mbkt_parent(ji,jj) 
    442442                  ! Input grid (account for partial cells if any): 
    443                   DO jk=1,N_in 
    444                      z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 
    445                      tabin(jk,1:jpts) = tabres(ji,jj,jk,1:jpts) 
    446                   END DO 
     443                  IF ( N_in > 0 ) THEN  
     444                     DO jk=1,N_in 
     445                        z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 
     446                        tabin(jk,1:jpts) = tabres(ji,jj,jk,1:jpts) 
     447                     END DO 
    447448                   
    448                   ! Intermediate grid: 
    449                   DO jk = 1, N_in 
    450                      h_in_i(jk) = e3t0_parent(ji,jj,jk) * &  
    451                        &       (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 
    452                   END DO 
    453                   z_in_i(1) = 0.5_wp * h_in_i(1) 
    454                   DO jk=2,N_in 
    455                      z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 
    456                   END DO 
    457                   z_in_i(1:N_in) = z_in_i(1:N_in)  - tabres(ji,jj,k2,n2) 
    458  
     449                     ! Intermediate grid: 
     450                     DO jk = 1, N_in 
     451                        h_in_i(jk) = e3t0_parent(ji,jj,jk) * &  
     452                          &       (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 
     453                     END DO 
     454                     z_in_i(1) = 0.5_wp * h_in_i(1) 
     455                     DO jk=2,N_in 
     456                        z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 
     457                     END DO 
     458                     z_in_i(1:N_in) = z_in_i(1:N_in)  - tabres(ji,jj,k2,n2) 
     459                  END IF 
    459460                  ! Output (Child) grid: 
    460461                  N_out = mbkt(ji,jj) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_update.F90

    r14086 r14200  
    192192      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 
    193193      ! 
    194 #if ! defined key_qco 
     194#if defined key_qco 
     195      CALL Agrif_ChildGrid_To_ParentGrid() 
     196      CALL Agrif_Update_qco 
     197      CALL Agrif_ParentGrid_To_ChildGrid() 
     198#elif defined key_linssh 
     199      ! 
     200#else 
    195201      Agrif_UseSpecialValueInUpdate = .TRUE. 
    196202      Agrif_SpecialValueFineGrid = 0. 
    … …  
    204210      CALL Agrif_ChildGrid_To_ParentGrid() 
    205211      CALL dom_vvl_update_UVF 
    206       CALL Agrif_ParentGrid_To_ChildGrid() 
    207 #else 
    208       CALL Agrif_ChildGrid_To_ParentGrid() 
    209       CALL Agrif_Update_qco 
    210212      CALL Agrif_ParentGrid_To_ChildGrid() 
    211213#endif 
    … …  
    232234 
    233235 
    234 #if ! defined key_qco 
     236#if ! defined key_qco   &&   ! defined key_linssh 
    235237   SUBROUTINE dom_vvl_update_UVF 
    236238      !!--------------------------------------------- 
    … …  
    11631165   END SUBROUTINE updateAVM 
    11641166 
    1165 #if ! defined key_qco 
     1167#if ! defined key_qco   &&   ! defined key_linssh 
    11661168   SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 
    11671169      !!--------------------------------------------- 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_top_interp.F90

    r14086 r14200  
    2727   PUBLIC Agrif_trc, interptrn 
    2828 
     29   !! * Substitutions 
     30#  include "domzgr_substitute.h90" 
    2931  !!---------------------------------------------------------------------- 
    3032   !! NEMO/NST 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_top_sponge.F90

    r14086 r14200  
    3030   PUBLIC Agrif_Sponge_trc, interptrn_sponge 
    3131 
     32   !! * Substitutions 
     33#  include "domzgr_substitute.h90" 
    3234   !!---------------------------------------------------------------------- 
    3335   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    … …  
    128130                  N_in = mbkt_parent(ji,jj) 
    129131                  ! Input grid (account for partial cells if any): 
    130                   DO jk=1,N_in 
    131                      z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 
    132                      tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra) 
    133                   END DO 
     132                  IF ( N_in > 0 ) THEN  
     133                     DO jk=1,N_in 
     134                        z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 
     135                        tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra) 
     136                     END DO 
    134137                   
    135                   ! Intermediate grid: 
    136                   DO jk = 1, N_in 
    137                      h_in_i(jk) = e3t0_parent(ji,jj,jk) * &  
    138                        &       (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 
    139                   END DO 
    140                   z_in_i(1) = 0.5_wp * h_in_i(1) 
    141                   DO jk=2,N_in 
    142                      z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 
    143                   END DO 
    144                   z_in_i(1:N_in) = z_in_i(1:N_in)  - tabres(ji,jj,k2,n2) 
    145  
     138                     ! Intermediate grid: 
     139                     DO jk = 1, N_in 
     140                        h_in_i(jk) = e3t0_parent(ji,jj,jk) * &  
     141                          &       (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 
     142                     END DO 
     143                     z_in_i(1) = 0.5_wp * h_in_i(1) 
     144                     DO jk=2,N_in 
     145                        z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 
     146                     END DO 
     147                     z_in_i(1:N_in) = z_in_i(1:N_in)  - tabres(ji,jj,k2,n2) 
     148                  END IF 
    146149                  ! Output (Child) grid: 
    147150                  N_out = mbkt(ji,jj) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_top_update.F90

    r14086 r14200  
    2626   PUBLIC Agrif_Update_Trc 
    2727 
     28   !! * Substitutions 
     29#  include "domzgr_substitute.h90" 
    2830   !!---------------------------------------------------------------------- 
    2931   !! NEMO/NST 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_user.F90

    r14086 r14200  
    365365         use_sign_north = .TRUE. 
    366366         sign_north = -1. 
     367         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)   ! must be called before unb_id to define ubdy 
     368         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)   ! must be called before vnb_id to define vbdy 
    367369         CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 
    368370         CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb ) 
    369          CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)   ! must be called before unb_id to define ubdy 
    370          CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)   ! must be called before vnb_id to define vbdy 
    371371         use_sign_north = .FALSE. 
    372372         ubdy(:,:) = 0._wp 
    373373         vbdy(:,:) = 0._wp 
    374       ELSE 
     374      ELSEIF ( ln_dynspg_EXP ) THEN  
    375375         Agrif_UseSpecialValue = ln_spc_dyn 
    376376         use_sign_north = .TRUE. 
    377377         sign_north = -1. 
     378         ubdy(:,:) = 0._wp 
     379         vbdy(:,:) = 0._wp 
    378380         CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 
    379381         CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb ) 
    … …  
    875877      ! 
    876878      ! Some checks 
     879      IF( (.NOT.ln_vert_remap).AND.(jpkglo>Agrif_Parent(jpkglo)) )                    CALL ctl_stop( 'STOP',    & 
     880         &   'agrif_nemo_init: Agrif children must have less or equal number of vertical levels without ln_vert_remap defined' )  
    877881      IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x   + nbghostcells_x   )   CALL ctl_stop( 'STOP',    & 
    878882         &   'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nn_hls + 2*nbghostcells_x' ) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/BDY/bdytides.F90

    r13286 r14200  
    162162               ! 
    163163               ! SSH fields 
    164                IF( ASSOCIATED(dta%ssh) ) THEN   ! we use bdy ssh on this mpi subdomain 
    165                   clfile = TRIM(filtide)//'_grid_T.nc' 
    166                   CALL iom_open( clfile , inum )  
    167                   igrd = 1                       ! Everything is at T-points here 
    168                   DO itide = 1, nb_harmo 
    169                      CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) ) 
    170                      CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) )  
     164               clfile = TRIM(filtide)//'_grid_T.nc' 
     165               CALL iom_open( clfile , inum )  
     166               igrd = 1                       ! Everything is at T-points here 
     167               DO itide = 1, nb_harmo 
     168                  CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) ) 
     169                  CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) )  
     170                  IF( ASSOCIATED(dta%ssh) ) THEN   ! we use bdy ssh on this mpi subdomain 
    171171                     DO ib = 1, SIZE(dta%ssh) 
    172172                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    … …  
    175175                        td%ssh0(ib,itide,2) = zti(ii,ij) 
    176176                     END DO 
    177                   END DO 
    178                   CALL iom_close( inum ) 
    179                ENDIF 
     177                  ENDIF 
     178               END DO 
     179               CALL iom_close( inum ) 
    180180               ! 
    181181               ! U fields 
    182                IF( ASSOCIATED(dta%u2d) ) THEN   ! we use bdy u2d on this mpi subdomain 
    183                   clfile = TRIM(filtide)//'_grid_U.nc' 
    184                   CALL iom_open( clfile , inum )  
    185                   igrd = 2                       ! Everything is at U-points here 
    186                   DO itide = 1, nb_harmo 
    187                      CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._wp) 
    188                      CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._wp) 
     182               clfile = TRIM(filtide)//'_grid_U.nc' 
     183               CALL iom_open( clfile , inum )  
     184               igrd = 2                       ! Everything is at U-points here 
     185               DO itide = 1, nb_harmo 
     186                  CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._wp) 
     187                  CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._wp) 
     188                  IF( ASSOCIATED(dta%u2d) ) THEN   ! we use bdy u2d on this mpi subdomain 
    189189                     DO ib = 1, SIZE(dta%u2d) 
    190190                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    … …  
    193193                        td%u0(ib,itide,2) = zti(ii,ij) 
    194194                     END DO 
    195                   END DO 
    196                   CALL iom_close( inum ) 
    197                ENDIF 
     195                  ENDIF  
     196               END DO  
     197               CALL iom_close( inum ) 
    198198               ! 
    199199               ! V fields 
    200                IF( ASSOCIATED(dta%v2d) ) THEN   ! we use bdy v2d on this mpi subdomain 
    201                   clfile = TRIM(filtide)//'_grid_V.nc' 
    202                   CALL iom_open( clfile , inum )  
    203                   igrd = 3                       ! Everything is at V-points here 
    204                   DO itide = 1, nb_harmo 
    205                      CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._wp) 
    206                      CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._wp) 
     200               clfile = TRIM(filtide)//'_grid_V.nc' 
     201               CALL iom_open( clfile , inum )  
     202               igrd = 3                       ! Everything is at V-points here 
     203               DO itide = 1, nb_harmo 
     204                  CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._wp) 
     205                  CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._wp) 
     206                  IF( ASSOCIATED(dta%v2d) ) THEN   ! we use bdy v2d on this mpi subdomain 
    207207                     DO ib = 1, SIZE(dta%v2d) 
    208208                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    … …  
    211211                        td%v0(ib,itide,2) = zti(ii,ij) 
    212212                     END DO 
    213                   END DO 
    214                   CALL iom_close( inum ) 
    215                ENDIF 
     213                  ENDIF  
     214               END DO 
     215               CALL iom_close( inum ) 
    216216               ! 
    217217               DEALLOCATE( ztr, zti )  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DIA/diawri.F90

    r14086 r14200  
    215215      ENDIF 
    216216 
    217 #if ! defined key_qco 
    218       CALL iom_put( "rhop", rhop(:,:,:) )          ! 3D potential density (sigma0) 
    219 #endif 
     217      IF( .NOT.lk_SWE )   CALL iom_put( "rhop", rhop(:,:,:) )          ! 3D potential density (sigma0) 
    220218 
    221219      IF ( iom_use("taubot") ) THEN                ! bottom stress 
    … …  
    360358      ENDIF 
    361359      !     
    362       IF ( iom_use("sKEf") ) THEN                        ! surface kinetic energy at F point 
     360      IF ( iom_use("ssKEf") ) THEN                        ! surface kinetic energy at F point 
    363361         z2d(:,:) = 0._wp                                ! CAUTION : only valid in SWE, not with bathymetry 
    364362         DO_2D( 0, 0, 0, 0 ) 
    … …  
    370368         END_2D 
    371369         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
    372          CALL iom_put( "sKEf", z2d )                      
     370         CALL iom_put( "ssKEf", z2d )                      
    373371      ENDIF 
    374372      ! 
    … …  
    473471      IF (ln_dia25h)   CALL dia_25h( kt, Kmm )        ! 25h averaging 
    474472       
    475       ! Output of vorticity terms 
    476       IF ( iom_use("relvor")    .OR. iom_use("plavor")    .OR.   & 
    477          & iom_use("relpotvor") .OR. iom_use("abspotvor") .OR.   & 
    478          & iom_use("Ens")                                        ) THEN 
     473      ! Output of surface vorticity terms 
     474      IF ( iom_use("ssrelvor")    .OR. iom_use("ssplavor")    .OR.   & 
     475         & iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") .OR.   & 
     476         & iom_use("ssEns")                                        ) THEN 
    479477         ! 
    480478         z2d(:,:) = 0._wp  
    … …  
    485483         END_2D 
    486484         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
    487          CALL iom_put( "relvor", z2d )                  ! relative vorticity ( zeta )  
    488          ! 
    489          CALL iom_put( "plavor", ff_f )                 ! planetary vorticity ( f ) 
     485         CALL iom_put( "ssrelvor", z2d )                  ! relative vorticity ( zeta )  
     486         ! 
     487         CALL iom_put( "ssplavor", ff_f )                 ! planetary vorticity ( f ) 
    490488         ! 
    491489         DO_2D( 1, 0, 1, 0 )   
    … …  
    498496         END_2D 
    499497         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
    500          CALL iom_put( "relpotvor", z2d )                  ! relative potential vorticity (zeta/h) 
     498         CALL iom_put( "ssrelpotvor", z2d )                  ! relative potential vorticity (zeta/h) 
    501499         ! 
    502500         DO_2D( 1, 0, 1, 0 ) 
    … …  
    509507         END_2D 
    510508         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
    511          CALL iom_put( "abspotvor", z2d )                  ! absolute potential vorticity ( q ) 
     509         CALL iom_put( "ssabspotvor", z2d )                  ! absolute potential vorticity ( q ) 
    512510         ! 
    513511         DO_2D( 1, 0, 1, 0 )   
    … …  
    515513         END_2D 
    516514         CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 
    517          CALL iom_put( "Ens", z2d )                        ! potential enstrophy ( 1/2*q2 ) 
     515         CALL iom_put( "ssEns", z2d )                        ! potential enstrophy ( 1/2*q2 ) 
    518516         ! 
    519517      ENDIF 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/dom_oce.F90

    r14072 r14200  
    136136   ! 
    137137   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ff_f  , ff_t                    !: Coriolis factor at f- & t-points  [1/s] 
     138    
    138139   !!---------------------------------------------------------------------- 
    139140   !! vertical coordinate and scale factors 
    140141   !! --------------------------------------------------------------------- 
     142#if defined key_qco 
     143   LOGICAL, PUBLIC, PARAMETER ::   lk_qco    = .TRUE.   !: qco key flag 
     144#else 
     145   LOGICAL, PUBLIC, PARAMETER ::   lk_qco    = .FALSE.  !: qco key flag 
     146#endif 
     147#if defined key_linssh 
     148   LOGICAL, PUBLIC, PARAMETER ::   lk_linssh = .TRUE.   !: linssh key flag 
     149#else 
     150   LOGICAL, PUBLIC, PARAMETER ::   lk_linssh = .FALSE.  !: linssh key flag 
     151#endif 
    141152   LOGICAL, PUBLIC ::   ln_zco       !: z-coordinate - full step 
    142153   LOGICAL, PUBLIC ::   ln_zps       !: z-coordinate - partial step 
    … …  
    151162   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3uw_0   !: uw-vert. scale factor [m] 
    152163   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3vw_0   !: vw-vert. scale factor [m] 
    153    !                                                        !  time-dependent scale factors 
    154 #if ! defined key_qco 
     164 
     165   !                                                        !  time-dependent scale factors     (domvvl) 
    155166   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e3t, e3u, e3v, e3w, e3uw, e3vw  !: vert. scale factor [m] 
    156167   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   e3f                             !: F-point vert. scale factor [m] 
    157 #endif 
    158    !                                                        !  time-dependent ratio ssh / h_0 
     168 
     169   !                                                        !  time-dependent ratio ssh / h_0   (domqco) 
    159170   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   r3t, r3u, r3v                   !: time-dependent    ratio at t-, u- and v-point [-] 
    160171   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   r3f                             !: mid-time-level    ratio at f-point            [-] 
    … …  
    165176   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdepw_0  !: w- depth              [m] 
    166177   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w_0  !: w- depth (sum of e3w) [m] 
    167    !                                                        !  time-dependent depths of cells 
     178    
     179   !                                                        !  time-dependent depths of cells   (domvvl) 
    168180   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::  gdept, gdepw 
    169181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::  gde3w 
    … …  
    174186   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hv_0, r1_hv_0   !: v-depth        [m] and [1/m] 
    175187   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hf_0, r1_hf_0   !: f-depth        [m] and [1/m] 
    176    !                                                        ! time-dependent heights of ocean water column 
    177 #if ! defined key_qco 
     188    
     189   !                                                        ! time-dependent heights of ocean water column   (domvvl) 
    178190   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ht          !: t-points           [m] 
    179 #endif 
    180191   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hu, r1_hu   !: u-depth            [m] and [1/m] 
    181192   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hv, r1_hv   !: v-depth            [m] and [1/m] 
    … …  
    207218   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET ::   tmask, umask, vmask, wmask, fmask   !: land/ocean mask at T-, U-, V-, W- and F-pts 
    208219   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 
     220   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET ::   fe3mask                             !: land/ocean mask at F-pts (qco only) 
     221 
    212222   !!---------------------------------------------------------------------- 
    213223   !! calendar variables 
    … …  
    301311         ! 
    302312      ii = ii+1 
    303       ALLOCATE( gdept_0(jpi,jpj,jpk)     , gdepw_0(jpi,jpj,jpk)     , gde3w_0(jpi,jpj,jpk) ,      & 
    304          &      gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(ii) ) 
    305          ! 
    306       ii = ii+1 
    307       ALLOCATE(  e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) ,      & 
    308          &       e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk)                      ,  STAT=ierr(ii) ) 
     313      ALLOCATE( gdept_0 (jpi,jpj,jpk) , gdepw_0 (jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) ,     & 
     314         &      gdept_1d(        jpk) , gdepw_1d(        jpk)                        , STAT=ierr(ii) ) 
     315         ! 
     316      ii = ii+1 
     317      ALLOCATE(  e3t_0 (jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) ,     & 
     318         &       e3w_0 (jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk)                      ,     & 
     319         &       e3t_1d(        jpk) , e3w_1d(        jpk)                                            , STAT=ierr(ii) ) 
     320         ! 
     321      ii = ii+1 
     322      ALLOCATE( ht_0(jpi,jpj) ,    hu_0(jpi,jpj)    ,    hv_0(jpi,jpj)     , hf_0(jpi,jpj) ,       & 
     323         &   r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) ,    r1_hv_0(jpi,jpj),   r1_hf_0(jpi,jpj) ,   STAT=ierr(ii)  ) 
    309324         ! 
    310325#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) ) 
     326         ! qco : ssh to h ratio and specific fmask 
     327      ii = ii+1 
     328      ALLOCATE( r3t  (jpi,jpj,jpt) , r3u  (jpi,jpj,jpt) , r3v  (jpi,jpj,jpt) , r3f  (jpi,jpj) ,      & 
     329         &      r3t_f(jpi,jpj)     , r3u_f(jpi,jpj)     , r3v_f(jpi,jpj)                      ,  STAT=ierr(ii) ) 
     330         ! 
     331      ii = ii+1 
     332      ALLOCATE( fe3mask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
     333         ! 
     334#elif defined key_linssh 
     335         ! linear ssh no time varying coordinate arrays 
    314336#else 
     337         ! vvl : time varation for all vertical coordinate variables 
     338      ii = ii+1 
     339      ALLOCATE( gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(ii) ) 
     340         ! 
    315341      ii = ii+1 
    316342      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
    317343         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
    318 #endif 
    319          ! 
    320       ii = ii+1 
    321       ALLOCATE( ht_0(jpi,jpj) ,    hu_0(jpi,jpj)    ,    hv_0(jpi,jpj)     , hf_0(jpi,jpj) ,       & 
    322          &   r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) ,    r1_hv_0(jpi,jpj),   r1_hf_0(jpi,jpj) ,   STAT=ierr(ii)  ) 
    323          ! 
    324 #if ! defined key_qco 
    325       ii = ii+1 
    326       ALLOCATE( ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
    327          &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
     344         ! 
     345      ii = ii+1 
     346      ALLOCATE( ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt) ,       & 
     347         &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt) ,   STAT=ierr(ii)  ) 
    328348#endif 
    329349         ! 
    … …  
    332352         ! 
    333353      ii = ii+1 
    334       ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) ) 
    335          ! 
    336       ii = ii+1 
    337       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        & 
     354      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                                           & 
    338355         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
    339          &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
     356         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj)                    , STAT=ierr(ii) ) 
    340357         ! 
    341358      ii = ii+1 
    … …  
    348365      ii = ii+1 
    349366      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 
    355367      ! 
    356368      dom_oce_alloc = MAXVAL(ierr) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domain.F90

    r14090 r14200  
    2828   USE oce            ! ocean variables 
    2929   USE dom_oce        ! domain: ocean 
     30   USE domtile        ! tiling utilities 
    3031#if defined key_qco 
    31    USE domqco         ! quasi-eulerian 
     32   USE domqco         ! quasi-eulerian coord. 
     33#elif defined key_linssh 
     34   !                  ! fix in time coord. 
    3235#else 
    33    USE domvvl         ! variable volume 
    34 #endif 
    35    USE sshwzv  , ONLY : ssh_init_rst   ! set initial ssh 
     36   USE domvvl         ! variable volume coord. 
     37#endif 
     38#if defined key_agrif 
     39   USE agrif_oce_interp, ONLY : Agrif_istate_ssh ! ssh interpolated from parent 
     40#endif 
    3641   USE sbc_oce        ! surface boundary condition: ocean 
    3742   USE trc_oce        ! shared ocean & passive tracers variab 
    … …  
    3944   USE domhgr         ! domain: set the horizontal mesh 
    4045   USE domzgr         ! domain: set the vertical mesh 
    41    USE domtile 
    4246   USE dommsk         ! domain: set the mask system 
    4347   USE domwri         ! domain: write the meshmask file 
    … …  
    5155   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
    5256   USE lib_mpp        ! distributed memory computing library 
    53    USE restart        ! only for lrst_oce 
     57   USE restart        ! only for lrst_oce and rst_read_ssh 
    5458 
    5559   IMPLICIT NONE 
    … …  
    169173         DO_2D( 1, 1, 1, 1 ) 
    170174            IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN 
    171                CALL ctl_stop( 'ssh_init_rst : ht_0 must be positive at potentially wet points' ) 
     175               CALL ctl_stop( 'dom_init : ht_0 must be positive at potentially wet points' ) 
    172176            ENDIF 
    173177         END_2D 
    … …  
    177181      ! 
    178182      !                                 != ssh initialization 
    179       IF( .NOT.l_offline .AND. .NOT.l_SAS ) THEN 
    180          CALL ssh_init_rst( Kbb, Kmm, Kaa ) 
    181       ELSE 
     183      ! 
     184      IF( l_offline .OR. l_SAS ) THEN        !* No ocean dynamics calculation : set to 0 
    182185         ssh(:,:,:) = 0._wp 
    183       ENDIF 
    184       ! 
     186#if defined key_agrif 
     187      ELSEIF( .NOT.Agrif_root() .AND.    & 
     188         &     ln_init_chfrpar ) THEN        !* Interpolate initial ssh from parent 
     189         CALL Agrif_istate_ssh( Kbb, Kmm, Kaa ) 
     190#endif 
     191      ELSE                                   !* Read in restart file or set by user 
     192         CALL rst_read_ssh( Kbb, Kmm, Kaa ) 
     193      ENDIF 
     194      !      
    185195#if defined key_qco 
    186196      !                                 != Quasi-Euerian coordinate case 
    187197      ! 
    188198      IF( .NOT.l_offline )   CALL dom_qco_init( Kbb, Kmm, Kaa ) 
     199#elif defined key_linssh 
     200      !                                 != Fix in time : key_linssh case, set through domzgr_substitute.h90 
    189201#else 
    190202      ! 
    … …  
    345357      IF(lwm) WRITE( numond, namdom ) 
    346358      ! 
     359#if defined key_linssh 
     360      ln_linssh = lk_linssh      ! overwrite ln_linssh with the logical associated with key_linssh 
     361#endif 
     362      ! 
    347363#if defined key_agrif 
    348364      IF( .NOT. Agrif_Root() ) THEN    ! AGRIF child, subdivide the Parent timestep 
    … …  
    371387      ! 
    372388#if defined key_qco 
    373       IF( ln_linssh )   CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh = T are incompatible' ) 
     389      IF( ln_linssh )   CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) 
    374390#endif 
    375391      ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domqco.F90

    r14053 r14200  
    116116      !                    !== Set of all other vertical scale factors  ==!  (now and before) 
    117117      !                                ! Horizontal interpolation of e3t 
     118#if defined key_RK3 
     119      CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb), r3f(:,:) ) 
     120      CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm)           ) 
     121#else 
    118122      CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb)           ) 
    119123      CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) 
     124#endif 
    120125      ! 
    121126   END SUBROUTINE dom_qco_zgr 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domvvl.F90

    r14086 r14200  
    22   !!====================================================================== 
    33   !!                       ***  MODULE domvvl   *** 
    4    !! Ocean :  
     4   !! Ocean : 
    55   !!====================================================================== 
    66   !! History :  2.0  !  2006-06  (B. Levier, L. Marie)  original code 
    … …  
    2626   USE timing          ! Timing 
    2727 
    28 #if defined key_agrif 
    29    USE agrif_oce       ! initial state interpolation 
    30    USE agrif_oce_interp  
    31 #endif 
    32  
    3328   IMPLICIT NONE 
    3429   PRIVATE 
    … …  
    5550   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_hdv                 ! retoring period for low freq. divergence 
    5651 
    57 #if defined key_qco 
     52#if defined key_qco   ||   defined key_linssh 
    5853   !!---------------------------------------------------------------------- 
    59    !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     54   !!   'key_qco'                        Quasi-Eulerian vertical coordinate 
     55   !!       OR         EMPTY MODULE 
     56   !!   'key_linssh'                        Fix in time vertical coordinate 
    6057   !!---------------------------------------------------------------------- 
    6158#else 
    … …  
    6360   !!   Default key      Old management of time varying vertical coordinate 
    6461   !!---------------------------------------------------------------------- 
    65     
     62 
    6663   !!---------------------------------------------------------------------- 
    6764   !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness 
    … …  
    7875   PUBLIC  dom_vvl_sf_update  ! called by step.F90 
    7976   PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
    80     
     77 
    8178   !! * Substitutions 
    8279#  include "do_loop_substitute.h90" 
    … …  
    114111      !!---------------------------------------------------------------------- 
    115112      !!                ***  ROUTINE dom_vvl_init  *** 
    116       !!                    
     113      !! 
    117114      !! ** Purpose :  Initialization of all scale factors, depths 
    118115      !!               and water column heights 
    … …  
    123120      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b) 
    124121      !!              - Regrid: e3[u/v](:,:,:,Kmm) 
    125       !!                        e3[u/v](:,:,:,Kmm)        
    126       !!                        e3w(:,:,:,Kmm)            
     122      !!                        e3[u/v](:,:,:,Kmm) 
     123      !!                        e3w(:,:,:,Kmm) 
    127124      !!                        e3[u/v]w_b 
    128       !!                        e3[u/v]w_n       
     125      !!                        e3[u/v]w_n 
    129126      !!                        gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 
    130127      !!              - h(t/u/v)_0 
    … …  
    156153      !!---------------------------------------------------------------------- 
    157154      !!                ***  ROUTINE dom_vvl_init  *** 
    158       !!                    
    159       !! ** Purpose :  Interpolation of all scale factors,  
     155      !! 
     156      !! ** Purpose :  Interpolation of all scale factors, 
    160157      !!               depths and water column heights 
    161158      !! 
    … …  
    164161      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b) 
    165162      !!              - Regrid: e3(u/v)_n 
    166       !!                        e3(u/v)_b        
    167       !!                        e3w_n            
    168       !!                        e3(u/v)w_b       
    169       !!                        e3(u/v)w_n       
     163      !!                        e3(u/v)_b 
     164      !!                        e3w_n 
     165      !!                        e3(u/v)w_b 
     166      !!                        e3(u/v)w_n 
    170167      !!                        gdept_n, gdepw_n and gde3w_n 
    171168      !!              - h(t/u/v)_0 
    … …  
    185182      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' )    ! from T to U 
    186183      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
    187       CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' )    ! from T to V  
     184      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' )    ! from T to V 
    188185      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
    189186      CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' )    ! from U to F 
    190       !                                ! Vertical interpolation of e3t,u,v  
     187      !                                ! Vertical interpolation of e3t,u,v 
    191188      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  )  ! from T to W 
    192189      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W'  ) 
    … …  
    210207         !    zcoef = tmask - wmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
    211208         !                             ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
    212          !                             ! 0.5 where jk = mikt      
     209         !                             ! 0.5 where jk = mikt 
    213210!!gm ???????   BUG ?  gdept(:,:,:,Kmm) as well as gde3w  does not include the thickness of ISF ?? 
    214211         zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 
    215212         gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 
    216213         gdept(ji,jj,jk,Kmm) =      zcoef  * ( gdepw(ji,jj,jk  ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm))  & 
    217             &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm))  
     214            &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm)) 
    218215         gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
    219216         gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 
    220217         gdept(ji,jj,jk,Kbb) =      zcoef  * ( gdepw(ji,jj,jk  ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb))  & 
    221             &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) +       e3w(ji,jj,jk,Kbb))  
     218            &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) +       e3w(ji,jj,jk,Kbb)) 
    222219      END_3D 
    223220      ! 
    … …  
    278275            IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
    279276               IF( nn_cfg == 3 ) THEN   ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 
    280                   ii0 = 103 + nn_hls - 1   ;   ii1 = 111 + nn_hls - 1       
     277                  ii0 = 103 + nn_hls - 1   ;   ii1 = 111 + nn_hls - 1 
    281278                  ij0 = 128 + nn_hls       ;   ij1 = 135 + nn_hls 
    282279                  frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  0.0_wp 
    … …  
    290287 
    291288 
    292    SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall )  
     289   SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 
    293290      !!---------------------------------------------------------------------- 
    294291      !!                ***  ROUTINE dom_vvl_sf_nxt  *** 
    295       !!                    
     292      !! 
    296293      !! ** Purpose :  - compute the after scale factors used in tra_zdf, dynnxt, 
    297294      !!                 tranxt and dynspg routines 
    298295      !! 
    299296      !! ** Method  :  - z_star case:  Repartition of ssh INCREMENT proportionnaly to the level thickness. 
    300       !!               - z_tilde_case: after scale factor increment =  
     297      !!               - z_tilde_case: after scale factor increment = 
    301298      !!                                    high frequency part of horizontal divergence 
    302299      !!                                  + retsoring towards the background grid 
    … …  
    306303      !! 
    307304      !! ** Action  :  - hdiv_lf    : restoring towards full baroclinic divergence in z_tilde case 
    308       !!               - tilde_e3t_a: after increment of vertical scale factor  
     305      !!               - tilde_e3t_a: after increment of vertical scale factor 
    309306      !!                              in z_tilde case 
    310307      !!               - e3(t/u/v)_a 
    … …  
    410407            un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj)           & 
    411408               &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj  ,jk) ) 
    412             vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj)           &  
     409            vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj)           & 
    413410               &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji  ,jj+1,jk) ) 
    414411            zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) 
    … …  
    455452               WRITE(numout, *) 'at i, j, k=', ijk_max 
    456453               WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 
    457                WRITE(numout, *) 'at i, j, k=', ijk_min             
     454               WRITE(numout, *) 'at i, j, k=', ijk_min 
    458455               CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 
    459456            ENDIF 
    … …  
    571568      !!---------------------------------------------------------------------- 
    572569      !!                ***  ROUTINE dom_vvl_sf_update  *** 
    573       !!                    
    574       !! ** Purpose :  for z tilde case: compute time filter and swap of scale factors  
     570      !! 
     571      !! ** Purpose :  for z tilde case: compute time filter and swap of scale factors 
    575572      !!               compute all depths and related variables for next time step 
    576573      !!               write outputs and restart file 
    … …  
    582579      !! ** Action  :  - tilde_e3t_(b/n) ready for next time step 
    583580      !!               - Recompute: 
    584       !!                    e3(u/v)_b        
    585       !!                    e3w(:,:,:,Kmm)            
    586       !!                    e3(u/v)w_b       
    587       !!                    e3(u/v)w_n       
     581      !!                    e3(u/v)_b 
     582      !!                    e3w(:,:,:,Kmm) 
     583      !!                    e3(u/v)w_b 
     584      !!                    e3(u/v)w_n 
    588585      !!                    gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm)  and gde3w 
    589586      !!                    h(u/v) and h(u/v)r 
    … …  
    616613            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 
    617614         ELSE 
    618             tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) &  
     615            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 
    619616            &         + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 
    620617         ENDIF 
    … …  
    628625      ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 
    629626      ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 
    630        
     627 
    631628      CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F'  ) 
    632        
     629 
    633630      ! Vertical scale factor interpolations 
    634631      CALL dom_vvl_interpol( e3t(:,:,:,Kmm),  e3w(:,:,:,Kmm), 'W'  ) 
    … …  
    649646         gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 
    650647         gdept(ji,jj,jk,Kmm) =    zcoef  * ( gdepw(ji,jj,jk  ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) )  & 
    651              &             + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm) )  
     648             &             + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm) ) 
    652649         gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
    653650      END_3D 
    … …  
    768765      !!--------------------------------------------------------------------- 
    769766      !!                   ***  ROUTINE dom_vvl_rst  *** 
    770       !!                      
     767      !! 
    771768      !! ** Purpose :   Read or write VVL file in restart file 
    772769      !! 
    … …  
    800797         IF( ln_rstart ) THEN                   !==  Read the restart file  ==! 
    801798            ! 
    802 #if defined key_agrif 
    803             IF ( (.NOT.Agrif_root()).AND.(ln_init_chfrpar) ) THEN 
    804                ! skip reading restart if initialized from parent: 
    805                id3 = -1 ; id4 = -1 ; id5 = -1 
    806             ELSE 
    807 #endif 
    808799            CALL rst_read_open                                          !*  open the restart file if necessary 
    809800            !                                         ! --------- ! 
    … …  
    815806            id5 = iom_varid( numror, 'hdiv_lf'    , ldstop = .FALSE. ) 
    816807            ! 
    817 #if defined key_agrif 
    818             ENDIF 
    819 #endif 
    820808            !                                                           !*  scale factors 
    821809            IF(lwp) WRITE(numout,*)    '          Kmm scale factor read in the restart file' 
    822810            CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
    823             WHERE ( tmask(:,:,:) == 0.0_wp )  
     811            WHERE ( tmask(:,:,:) == 0.0_wp ) 
    824812               e3t(:,:,:,Kmm) = e3t_0(:,:,:) 
    825813            END WHERE 
    826814            IF( l_1st_euler ) THEN                       ! euler 
    827815               IF(lwp) WRITE(numout,*) '          Euler first time step : e3t(Kbb) = e3t(Kmm)' 
    828                e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
     816               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    829817            ELSE                                         ! leap frog 
    830818               IF(lwp) WRITE(numout,*) '          Kbb scale factor read in the restart file' 
    831819               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 
    832                WHERE ( tmask(:,:,:) == 0.0_wp )  
     820               WHERE ( tmask(:,:,:) == 0.0_wp ) 
    833821                  e3t(:,:,:,Kbb) = e3t_0(:,:,:) 
    834822               END WHERE 
    … …  
    854842                     CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
    855843                  ENDIF 
    856                ELSE  
    857                  tilde_e3t_b(:,:,:) = 0.0_wp 
    858                  tilde_e3t_n(:,:,:) = 0.0_wp 
     844               ELSE 
     845                  tilde_e3t_b(:,:,:) = 0.0_wp 
     846                  tilde_e3t_n(:,:,:) = 0.0_wp 
    859847               ENDIF 
    860848               !                                      ! ------------ ! 
    … …  
    864852                     CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 
    865853                  ELSE                ! array is missing 
    866                      hdiv_lf(:,:,:) = 0.0_wp  
     854                     hdiv_lf(:,:,:) = 0.0_wp 
    867855                  ENDIF 
    868856               ENDIF 
    … …  
    885873      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN       !  Create restart file  ! 
    886874         !                                       !=======================! 
    887 #if defined key_agrif 
    888          IF ( .NOT.Agrif_root().AND.(ln_init_chfrpar) ) THEN 
    889             ! Interpolate initial ssh from parent: 
    890             CALL Agrif_istate_ssh( Kbb, Kmm ) 
    891             ! 
    892             DO jk = 1, jpk 
    893                e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm)  ) & 
    894                  &                              / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   & 
    895                  &              + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 
    896             END DO 
    897             e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    898          ENDIF 
    899 #endif 
    900875         ! 
    901876         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    … …  
    911886            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 
    912887         END IF 
    913          !                                           ! -------------!     
     888         !                                           ! -------------! 
    914889         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    915890            !                                        ! ------------ ! 
    … …  
    925900      !!--------------------------------------------------------------------- 
    926901      !!                  ***  ROUTINE dom_vvl_ctl  *** 
    927       !!                 
     902      !! 
    928903      !! ** Purpose :   Control the consistency between namelist options 
    929904      !!                for vertical coordinate 
    … …  
    934909         &              ln_vvl_zstar_at_eqtor      , rn_ahe3     , rn_rst_e3t            , & 
    935910         &              rn_lf_cutoff               , rn_zdef_max , ln_vvl_dbg                ! not yet implemented: ln_vvl_kepe 
    936       !!----------------------------------------------------------------------  
     911      !!---------------------------------------------------------------------- 
    937912      ! 
    938913      READ  ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domzgr_substitute.h90

    r14053 r14200  
    2828#   define  gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t))) 
    2929#   define  gde3w(i,j,k)   (gdept_0(i,j,k)*(1._wp+r3t(i,j,Kmm))-ssh(i,j,Kmm)) 
     30#elif defined key_linssh 
     31#   define  e3t(i,j,k,t)   e3t_0(i,j,k) 
     32#   define  e3u(i,j,k,t)   e3u_0(i,j,k) 
     33#   define  e3v(i,j,k,t)   e3v_0(i,j,k) 
     34#   define  e3f(i,j,k)     e3f_0(i,j,k) 
     35#   define  e3f_vor(i,j,k) e3f_0vor(i,j,k) 
     36#   define  e3w(i,j,k,t)   e3w_0(i,j,k) 
     37#   define  e3uw(i,j,k,t)  e3uw_0(i,j,k) 
     38#   define  e3vw(i,j,k,t)  e3vw_0(i,j,k) 
     39#   define  ht(i,j)        ht_0(i,j) 
     40#   define  hu(i,j,t)      hu_0(i,j) 
     41#   define  hv(i,j,t)      hv_0(i,j) 
     42#   define  r1_hu(i,j,t)   r1_hu_0(i,j) 
     43#   define  r1_hv(i,j,t)   r1_hv_0(i,j) 
     44#   define  gdept(i,j,k,t) gdept_0(i,j,k) 
     45#   define  gdepw(i,j,k,t) gdepw_0(i,j,k) 
     46#   define  gde3w(i,j,k)   (gdept_0(i,j,k)-ssh(i,j,Kmm)) 
    3047#endif 
    3148!!---------------------------------------------------------------------- 
    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))) 
     49 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/dtatsd.F90

    r14090 r14200  
    142142      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers 
    143143      INTEGER ::   itile 
     144      INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n 
    144145      REAL(wp)::   zl, zi                             ! local scalars 
    145146      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace 
    … …  
    157158         IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
    158159            IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN    ! some hand made alterations 
     160               irec_n(jp_tem) = sf_tsd(jp_tem)%nrec(2,sf_tsd(jp_tem)%naa)            ! Determine if there is new data (ln_tint = F) 
     161               irec_n(jp_sal) = sf_tsd(jp_sal)%nrec(2,sf_tsd(jp_sal)%naa)            ! If not, then do not apply the increments 
     162               IF( kt == nit000 ) irec_b(:) = -1 
    159163               ! 
    160164               ij0 = 101 + nn_hls       ;   ij1 = 109 + nn_hls                       ! Reduced T & S in the Alboran Sea 
    161165               ii0 = 141 + nn_hls - 1   ;   ii1 = 155 + nn_hls - 1 
    162                DO jj = mj0(ij0), mj1(ij1) 
    163                   DO ji = mi0(ii0), mi1(ii1) 
    164                      sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 
    165                      sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 
    166                      sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 
    167                      ! 
    168                      sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 
    169                      sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 
    170                      sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 
    171                      sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 
     166               IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN 
     167                  DO jj = mj0(ij0), mj1(ij1) 
     168                     DO ji = mi0(ii0), mi1(ii1) 
     169                        sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 
     170                        sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 
     171                        sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 
     172                     END DO 
    172173                  END DO 
    173                END DO 
     174                  irec_b(jp_tem) = irec_n(jp_tem) 
     175               ENDIF 
     176               ! 
     177               IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN 
     178                  DO jj = mj0(ij0), mj1(ij1) 
     179                     DO ji = mi0(ii0), mi1(ii1) 
     180                        sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 
     181                        sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 
     182                        sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 
     183                        sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 
     184                     END DO 
     185                  END DO 
     186                  irec_b(jp_sal) = irec_n(jp_sal) 
     187               ENDIF 
     188               ! 
    174189               ij0 =  87 + nn_hls       ;   ij1 =  96 + nn_hls                       ! Reduced temperature in Red Sea 
    175190               ii0 = 148 + nn_hls - 1   ;   ii1 = 160 + nn_hls - 1 
    … …  
    197212         ENDIF 
    198213         ! 
    199          ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case, but did not work in the zco case 
    200214         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )                  ! vertical interpolation of T & S 
    201215            DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    … …  
    233247         ! 
    234248         IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
    235             ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case 
    236249            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    237250               ik = mbkt(ji,jj) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/istate.F90

    r14086 r14200  
    9090 
    9191#if defined key_agrif 
    92       IF ( (.NOT.Agrif_root()).AND.ln_init_chfrpar ) THEN 
     92      IF ( .NOT.Agrif_root() .AND. ln_init_chfrpar ) THEN 
    9393         numror = 0                           ! define numror = 0 -> no restart file to read 
    9494         ln_1st_euler = .true.                ! Set time-step indicator at nit000 (euler forward) 
    … …  
    9797         ! 
    9898         ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 
    99 !!st 
    100 !!st need for a recent agrif version to be displaced toward ssh_init_rst with agrif_istate_ssh 
    101          ssh(:,:,    Kmm) = ssh(:,:    ,Kbb) 
    102 !!st end 
    10399         uu (:,:,:  ,Kmm) = uu (:,:,:  ,Kbb) 
    104100         vv (:,:,:  ,Kmm) = vv (:,:,:  ,Kbb) 
    … …  
    116112            CALL day_init                        ! model calendar (using both namelist and restart infos) 
    117113            !                                    ! Initialization of ocean to zero 
     114            ! 
    118115            IF( ln_tsd_init ) THEN                
    119116               CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) )       ! read 3D T and S data at nit000 
    120117               ! 
    121                ssh(:,:,Kbb)   = 0._wp               ! set the ocean at rest 
    122                uu  (:,:,:,Kbb) = 0._wp 
     118               uu  (:,:,:,Kbb) = 0._wp               ! set the ocean at rest 
    123119               vv  (:,:,:,Kbb) = 0._wp   
    124                ! 
    125                IF( ll_wd ) THEN 
    126                   ssh(:,:,Kbb) =  -ssh_ref  ! Added in 30 here for bathy that adds 30 as Iterative test CEOD  
    127                   ! 
    128                   ! Apply minimum wetdepth criterion 
    129                   ! 
    130                   DO_2D( 1, 1, 1, 1 ) 
    131                      IF( ht_0(ji,jj) + ssh(ji,jj,Kbb)  < rn_wdmin1 ) THEN 
    132                         ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) 
    133                      ENDIF 
    134                   END_2D 
    135                ENDIF  
    136120               ! 
    137121            ELSE                                 ! user defined initial T and S 
    … …  
    142126            ENDIF 
    143127            ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    144             ssh (:,:,Kmm)     = ssh(:,:,Kbb)    
    145             uu   (:,:,:,Kmm)   = uu  (:,:,:,Kbb) 
    146             vv   (:,:,:,Kmm)   = vv  (:,:,:,Kbb) 
     128            uu    (:,:,:,Kmm) = uu   (:,:,:,Kbb) 
     129            vv    (:,:,:,Kmm) = vv   (:,:,:,Kbb) 
    147130 
    148131         ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynatf.F90

    r14072 r14200  
    6060   PUBLIC    dyn_atf   ! routine called by step.F90 
    6161 
    62 #if defined key_qco 
     62#if defined key_qco   ||   defined key_linssh 
    6363   !!---------------------------------------------------------------------- 
    64    !!   'key_qco'      EMPTY ROUTINE     Quasi-Eulerian vertical coordonate 
     64   !!   'key_qco'                        Quasi-Eulerian vertical coordinate 
     65   !!       OR         EMPTY MODULE 
     66   !!   'key_linssh'                        Fix in time vertical coordinate 
    6567   !!---------------------------------------------------------------------- 
    6668CONTAINS 
    6769 
    68    SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 
     70   SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 
    6971      INTEGER                             , INTENT(in   ) :: kt               ! ocean time-step index 
    7072      INTEGER                             , INTENT(in   ) :: Kbb, Kmm, Kaa    ! before and after time level indices 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynatf_qco.F90

    r14053 r14200  
    6666CONTAINS 
    6767 
    68    SUBROUTINE dyn_atf_qco ( kt, Kbb, Kmm, Kaa, puu, pvv ) 
     68   SUBROUTINE dyn_atf_qco( kt, Kbb, Kmm, Kaa, puu, pvv ) 
    6969      !!---------------------------------------------------------------------- 
    7070      !!                  ***  ROUTINE dyn_atf_qco  *** 
    … …  
    196196      ! JC: Would be more clever to swap variables than to make a full vertical 
    197197      ! integration 
    198       ! CAUTION : calculation need to be done in the same way than see GM   
     198      ! CAUTION : calculation need to be done in the same way than see GM 
     199#if defined key_linssh 
     200      uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 
     201      uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) 
     202      vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) 
     203      vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) 
     204      DO jk = 2, jpkm1 
     205         uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) 
     206         uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) 
     207         vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) 
     208         vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 
     209      END DO 
     210      uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) 
     211      vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) 
     212      uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) 
     213      vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) 
     214#else 
    199215      uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 
    200216      uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) 
    … …  
    211227      uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) 
    212228      vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) 
     229#endif 
    213230      ! 
    214231      IF( .NOT.ln_dynspg_ts ) THEN        ! output the barotropic currents 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynhpg.F90

    r14064 r14200  
    183183      ENDIF 
    184184      ! 
    185       IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf.OR.ln_hpg_djc) )          & 
    186          &   CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ',   & 
    187          &                 '   the standard jacobian formulation hpg_sco    or '    ,   & 
    188          &                 '   the pressure jacobian formulation hpg_prj'             ) 
    189          ! 
     185      IF( .NOT.ln_linssh .AND. (ln_hpg_zco.OR.ln_hpg_zps) )   & 
     186         &   CALL ctl_stop( 'dyn_hpg_init : non-linear free surface incompatible with hpg_zco or hpg_zps' ) 
     187      ! 
     188      IF( (.NOT.ln_hpg_isf .AND. ln_isfcav) .OR. (ln_hpg_isf .AND. .NOT.ln_isfcav) )                  & 
     189         &   CALL ctl_stop( 'dyn_hpg_init : ln_hpg_isf=T requires ln_isfcav=T and vice versa' )   
     190      ! 
     191#if defined key_qco 
    190192      IF( ln_hpg_isf ) THEN 
    191          IF( .NOT. ln_isfcav )   CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 
    192        ELSE 
    193          IF(       ln_isfcav )   CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 
     193         CALL ctl_stop( 'dyn_hpg_init : key_qco and ln_hpg_isf not yet compatible' ) 
    194194      ENDIF 
     195#endif 
    195196      ! 
    196197      !                               ! Set nhpg from ln_hpg_... flags & consistency check 
    … …  
    239240         END IF 
    240241      END IF 
     242      ! 
    241243   END SUBROUTINE dyn_hpg_init 
    242244 
    … …  
    756758      ! 4. a) Upper half of top-most grid box, compute and store 
    757759      !------------------------------------------------------------- 
    758 ! *** AY note: ssh(ji,jj,Kmm) + gde3w(ji,jj,1) = e3w(ji,jj,1) 
     760! *** AY note: ssh(ji,jj,Kmm) + gde3w(ji,jj,1) = e3w(ji,jj,1,Kmm) 
    759761      DO_2D( 0, 1, 0, 1) 
    760762         z_rho_k(ji,jj,1) =  grav * ( ssh(ji,jj,Kmm) + gde3w(ji,jj,1) )                        &  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynvor.F90

    r14072 r14200  
    406406         END SELECT 
    407407         ! 
    408 #if defined key_qco 
     408#if defined key_qco   ||   defined key_linssh 
    409409         DO_2D( 1, 0, 1, 0 )                 !==  potential vorticity  ==!   (key_qco) 
    410410            zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 
    … …  
    533533         ! 
    534534         ! 
    535 #if defined key_qco 
     535#if defined key_qco   ||   defined key_linssh 
    536536         DO_2D( 1, 0, 1, 0 )                 !==  potential vorticity  ==!   (key_qco) 
    537537            zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 
    … …  
    624624         !                                             ! =============== 
    625625         ! 
    626 #if defined key_qco 
     626#if defined key_qco   ||   defined key_linssh 
    627627         DO_2D( 1, 0, 1, 0 )                 ! == reciprocal of e3 at F-point (key_qco) 
    628628            z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) 
    … …  
    952952         ! 
    953953      END SELECT 
    954 #if defined key_qco 
    955       SELECT CASE( nvor_scheme )    ! qco case: pre-computed a specific e3f_0 for some vorticity schemes 
     954#if defined key_qco   ||   defined key_linssh 
     955      SELECT CASE( nvor_scheme )    ! qco or linssh cases : pre-computed a specific e3f_0 for some vorticity schemes 
    956956      CASE( np_ENS , np_ENE , np_EEN , np_MIX ) 
    957957         ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/sshwzv.F90

    r14053 r14200  
    1818   !!   ssh_atf       : time filter the ssh arrays 
    1919   !!   wzv           : compute now vertical velocity 
    20    !!   ssh_init_rst  : ssh set from restart or domcfg.nc file or usr_def_istat_ssh 
    2120   !!---------------------------------------------------------------------- 
    2221   USE oce            ! ocean dynamics and tracers variables 
    … …  
    2928   USE bdy_oce , ONLY : ln_bdy, bdytmask   ! Open BounDarY 
    3029   USE bdydyn2d       ! bdy_ssh routine 
     30   USE wet_dry        ! Wetting/Drying flux limiting 
    3131#if defined key_agrif 
    3232   USE agrif_oce 
    … …  
    4141   USE lib_mpp        ! MPP library 
    4242   USE timing         ! Timing 
    43    USE wet_dry        ! Wetting/Drying flux limiting 
    44    USE usrdef_istate, ONLY : usr_def_istate_ssh   ! user defined ssh initial state  
    4543    
    4644   IMPLICIT NONE 
    … …  
    5149   PUBLIC   wAimp          ! called by step.F90 
    5250   PUBLIC   ssh_atf        ! called by step.F90 
    53    PUBLIC   ssh_init_rst   ! called by domain.F90 
    5451 
    5552   !! * Substitutions 
    … …  
    436433      ! 
    437434   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 
    520435       
    521436   !!====================================================================== 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ICB/icbutl.F90

    r14030 r14200  
    5757   PUBLIC   icb_utl_heat          ! routine called in icbdia module 
    5858 
     59   !! * Substitutions 
     60#  include "domzgr_substitute.h90" 
    5961   !!---------------------------------------------------------------------- 
    6062   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    127129            CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) 
    128130            voce_e(:,:,jk) = ztmp(:,:) 
     131            ! 
     132            e3t_e(1:jpi,1:jpj,jk) = e3t(:,:,jk,Kmm) 
    129133         END DO 
    130          toce_e(1:jpi,1:jpj,1:jpk) = ts(:,:,:,1,Kmm) 
    131          e3t_e (1:jpi,1:jpj,1:jpk) = e3t(:,:,:,Kmm) 
     134         toce_e(1:jpi,1:jpj,:) = ts(:,:,:,1,Kmm) 
    132135      END IF 
    133136      ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/IOM/restart.F90

    r14072 r14200  
    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 
     13   !!            4.1  !  2020-11  (S. Techene, G. Madec)  move ssh initiatlisation in rst_read_ssh 
     14   !!             -   !                                   add restart in Shallow Water Eq. case 
    1415   !!---------------------------------------------------------------------- 
    1516 
    1617   !!---------------------------------------------------------------------- 
    17    !!   rst_opn    : open the ocean restart file 
    18    !!   rst_write  : write the ocean restart file 
    19    !!   rst_read   : read the ocean restart file 
     18   !!   rst_opn       : open the ocean restart file for writting 
     19   !!   rst_write     : write the ocean restart file 
     20   !!   rst_read_open : open the restart file for reading  
     21   !!   rst_read      : read the ocean restart file 
     22   !!   rst_read_ssh  : ssh set from restart or domcfg.nc file or usr_def_istat_ssh 
    2023   !!---------------------------------------------------------------------- 
    21    USE oce             ! ocean dynamics and tracers 
    22    USE dom_oce         ! ocean space and time domain 
    23    USE sbc_ice         ! only lk_si3 
    24    USE phycst          ! physical constants 
    25    USE eosbn2          ! equation of state            (eos bn2 routine) 
    26    USE trdmxl_oce      ! ocean active mixed layer tracers trends variables 
     24   USE oce            ! ocean dynamics and tracers 
     25   USE dom_oce        ! ocean space and time domain 
     26   USE sbc_ice        ! only lk_si3 
     27   USE phycst         ! physical constants 
     28   USE eosbn2         ! equation of state 
     29   USE wet_dry        ! Wetting/Drying flux limiting 
     30   USE usrdef_istate, ONLY : usr_def_istate_ssh   ! user defined ssh initial state  
     31   USE trdmxl_oce     ! ocean active mixed layer tracers trends variables 
     32   USE diu_bulk       ! ??? 
    2733   ! 
    28    USE in_out_manager  ! I/O manager 
    29    USE iom             ! I/O module 
    30    USE diu_bulk 
    31    USE lib_mpp         ! distribued memory computing library 
     34   USE in_out_manager ! I/O manager 
     35   USE iom            ! I/O module 
     36   USE lib_mpp        ! distribued memory computing library 
    3237 
    3338   IMPLICIT NONE 
    3439   PRIVATE 
    3540 
    36    PUBLIC   rst_opn         ! routine called by step module 
    37    PUBLIC   rst_write       ! routine called by step module 
    38    PUBLIC   rst_read        ! routine called by istate module 
    39    PUBLIC   rst_read_open   ! routine called in rst_read and (possibly) in dom_vvl_init 
    40  
     41   PUBLIC   rst_opn         ! called by step.F90 
     42   PUBLIC   rst_write       ! called by step.F90 
     43   PUBLIC   rst_read_open   ! called in rst_read_ssh 
     44   PUBLIC   rst_read        ! called by istate.F90 
     45   PUBLIC   rst_read_ssh    ! called by domain.F90 
     46    
     47   !! * Substitutions 
     48#  include "do_loop_substitute.h90" 
     49#  include "domzgr_substitute.h90" 
    4150   !!---------------------------------------------------------------------- 
    4251   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    142151      !! 
    143152      !!                NB: ssh is written here (rst_write) 
    144       !!                    but is read or set in DYN/sshwzv:shh_init_rst 
     153      !!                    but is read or set in rst_read_ssh 
    145154      !!---------------------------------------------------------------------- 
    146155      INTEGER, INTENT(in) ::   kt         ! ocean time-step 
    147156      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    148157      !!---------------------------------------------------------------------- 
    149                      CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rn_Dt       )   ! dynamics time step 
    150                      IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'OCE', numrow )   ! save only ocean delayed global communication variables 
    151  
    152       IF ( .NOT. ln_diurnal_only ) THEN 
    153                      CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb) )     ! before fields 
    154                      CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vv(:,:,:       ,Kbb) ) 
    155                      CALL iom_rstput( kt, nitrst, numrow, 'tb'     , ts(:,:,:,jp_tem,Kbb) ) 
    156                      CALL iom_rstput( kt, nitrst, numrow, 'sb'     , ts(:,:,:,jp_sal,Kbb) ) 
    157                      CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , ssh(:,:         ,Kbb)) 
    158                      ! 
    159                      CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm) )     ! now fields 
    160                      CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vv(:,:,:       ,Kmm) ) 
    161                      CALL iom_rstput( kt, nitrst, numrow, 'tn'     , ts(:,:,:,jp_tem,Kmm) ) 
    162                      CALL iom_rstput( kt, nitrst, numrow, 'sn'     , ts(:,:,:,jp_sal,Kmm) ) 
    163                      CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , ssh(:,:         ,Kmm)) 
    164                      CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop      ) 
    165       ENDIF 
    166  
    167       IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) 
     158      ! 
     159         CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rn_Dt       )   ! dynamics time step 
     160      ! 
     161      IF( .NOT.lwxios )   CALL iom_delay_rst( 'WRITE', 'OCE', numrow )   ! save only ocean delayed global communication variables 
     162      ! 
     163      IF( .NOT.ln_diurnal_only ) THEN 
     164         CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , ssh(:,:        ,Kbb) )     ! before fields 
     165         CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb) ) 
     166         CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vv(:,:,:       ,Kbb) ) 
     167         IF( .NOT.lk_SWE ) THEN 
     168            CALL iom_rstput( kt, nitrst, numrow, 'tb'  , ts(:,:,:,jp_tem,Kbb) ) 
     169            CALL iom_rstput( kt, nitrst, numrow, 'sb'  , ts(:,:,:,jp_sal,Kbb) ) 
     170         ENDIF 
     171         ! 
     172#if ! defined key_RK3 
     173         CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , ssh(:,:        ,Kmm) )     ! now fields 
     174         CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm) ) 
     175         CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vv(:,:,:       ,Kmm) ) 
     176         IF( .NOT.lk_SWE ) THEN 
     177            CALL iom_rstput( kt, nitrst, numrow, 'tn'  , ts(:,:,:,jp_tem,Kmm) ) 
     178            CALL iom_rstput( kt, nitrst, numrow, 'sn'  , ts(:,:,:,jp_sal,Kmm) ) 
     179            CALL iom_rstput( kt, nitrst, numrow, 'rhop', rhop                 ) 
     180         ENDIF 
     181#endif 
     182      ENDIF 
     183 
     184      IF( ln_diurnal )   CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) 
    168185      IF( kt == nitrst ) THEN 
    169          IF(.NOT.lwxios) THEN 
     186         IF( .NOT.lwxios ) THEN 
    170187            CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    171188         ELSE 
    … …  
    177194!!gm  not sure what to do here   ===>>>  ask to Sebastian 
    178195         lrst_oce = .FALSE. 
    179             IF( ln_rst_list ) THEN 
    180                nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 
    181                nitrst = nn_stocklist( nrst_lst ) 
    182             ENDIF 
     196         IF( ln_rst_list ) THEN 
     197            nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 
     198            nitrst  = nn_stocklist( nrst_lst ) 
     199         ENDIF 
    183200      ENDIF 
    184201      ! 
    … …  
    245262      !!                    (sshb) 
    246263      !! 
    247       !!                NB: ssh is read or set in DYN/sshwzv:shh_init_rst 
    248       !!                    but is written     in IOM/restart:rst_write 
    249       !!---------------------------------------------------------------------- 
    250       INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
     264      !!                NB: ssh is read or set in rst_read_ssh 
     265      !!---------------------------------------------------------------------- 
     266      INTEGER          , INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    251267      INTEGER  ::   jk 
    252268      REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d 
    253       !!---------------------------------------------------------------------- 
    254       ! 
    255       IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
     269      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   :: zgdept       ! 3D workspace for QCO 
     270      !!---------------------------------------------------------------------- 
     271      ! 
     272      IF(.NOT.lrxios )   CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
    256273      ! 
    257274      !                             !*  Diurnal DSST 
    258275      IF( ln_diurnal )   CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 
    259       IF ( ln_diurnal_only ) THEN 
     276      IF( ln_diurnal_only ) THEN 
    260277         IF(lwp) WRITE( numout, * ) & 
    261278         &   "rst_read:- ln_diurnal_only set, setting rhop=rho0" 
    … …  
    266283      ENDIF 
    267284      ! 
    268       !                             !*  Read Kmm fields 
     285#if defined key_RK3 
     286      !                             !*  Read Kbb fields   (NB: in RK3 Kmm = Kbb = Nbb) 
     287      IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields read in the restart file' 
     288      CALL iom_get( numror, jpdom_auto, 'ub'   , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
     289      CALL iom_get( numror, jpdom_auto, 'vb'   , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
     290      IF( .NOT.lk_SWE ) THEN 
     291         CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
     292         CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
     293      ENDIF 
     294#else 
     295      !                             !*  Read Kmm fields   (MLF only) 
    269296      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 
     297      CALL iom_get( numror, jpdom_auto, 'un'   , uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
     298      CALL iom_get( numror, jpdom_auto, 'vn'   , vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
     299      IF( .NOT.lk_SWE ) THEN 
     300         CALL iom_get( numror, jpdom_auto, 'tn', ts(:,:,:,jp_tem,Kmm) ) 
     301         CALL iom_get( numror, jpdom_auto, 'sn', ts(:,:,:,jp_sal,Kmm) ) 
     302      ENDIF 
     303      ! 
     304      IF( l_1st_euler ) THEN        !*  Euler restart   (MLF only) 
    276305         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) 
     306         uu(:,:,:  ,Kbb) = uu(:,:,:  ,Kmm)         ! all before fields set to now values 
    279307         vv(:,:,:  ,Kbb) = vv(:,:,:  ,Kmm) 
    280       ELSE                          !* Leap frog restart 
     308         IF( .NOT.lk_SWE ) ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) 
     309         ! 
     310      ELSE                          !* Leap frog restart   (MLF only) 
    281311         IF(lwp) WRITE(numout,*) '           Kbb u, v and T-S fields read in the restart file' 
    282          CALL iom_get( numror, jpdom_auto, 'ub'     , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
    283          CALL iom_get( numror, jpdom_auto, 'vb'     , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
    284          CALL iom_get( numror, jpdom_auto, 'tb'     , ts(:,:,:,jp_tem,Kbb) ) 
    285          CALL iom_get( numror, jpdom_auto, 'sb'     , ts(:,:,:,jp_sal,Kbb) ) 
    286       ENDIF 
    287       ! 
    288       IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
    289          CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop )   ! now    potential density 
    290       ELSE 
    291          CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) 
     312         CALL iom_get( numror, jpdom_auto, 'ub'   , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
     313         CALL iom_get( numror, jpdom_auto, 'vb'   , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
     314         IF( .NOT.lk_SWE ) THEN 
     315            CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) 
     316            CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) 
     317         ENDIF 
     318      ENDIF 
     319#endif 
     320      ! 
     321      IF( .NOT.lk_SWE ) THEN 
     322         IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
     323            CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop )   ! now    potential density 
     324         ELSE 
     325#if defined key_qco 
     326            ALLOCATE( zgdept(jpi,jpj,jpk) ) 
     327            DO jk = 1, jpk 
     328               zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 
     329            END DO 
     330            CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, zgdept ) 
     331            DEALLOCATE( zgdept ) 
     332#else 
     333            CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) 
     334#endif 
     335         ENDIF 
    292336      ENDIF 
    293337      ! 
    294338   END SUBROUTINE rst_read 
     339 
     340 
     341   SUBROUTINE rst_read_ssh( Kbb, Kmm, Kaa ) 
     342      !!--------------------------------------------------------------------- 
     343      !!                   ***  ROUTINE rst_read_ssh  *** 
     344      !! 
     345      !! ** Purpose :   ssh initialization of the sea surface height (ssh) 
     346      !! 
     347      !! ** Method  :   set ssh from restart or read configuration, or user_def 
     348      !!              * ln_rstart = T 
     349      !!                   USE of IOM library to read ssh in the restart file 
     350      !!                   Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T 
     351      !! 
     352      !!              * otherwise  
     353      !!                   call user defined ssh or 
     354      !!                   set to -ssh_ref in wet and drying case with domcfg.nc 
     355      !! 
     356      !!              NB: ssh_b/n are written by restart.F90 
     357      !!---------------------------------------------------------------------- 
     358      INTEGER, INTENT(in) ::   Kbb, Kmm, Kaa   ! ocean time level indices 
     359      ! 
     360      INTEGER ::   ji, jj, jk 
     361      !!---------------------------------------------------------------------- 
     362      ! 
     363      IF(lwp) THEN 
     364         WRITE(numout,*) 
     365         WRITE(numout,*) 'rst_read_ssh : ssh initialization' 
     366         WRITE(numout,*) '~~~~~~~~~~~~ ' 
     367      ENDIF 
     368      ! 
     369      !                            !=============================! 
     370      IF( ln_rstart ) THEN         !==  Read the restart file  ==! 
     371         !                         !=============================! 
     372         ! 
     373#if defined key_RK3 
     374         !                                     !*  RK3: Read ssh at Kbb 
     375         IF(lwp) WRITE(numout,*) 
     376         IF(lwp) WRITE(numout,*)    '      Kbb sea surface height read in the restart file' 
     377         CALL iom_get( numror, jpdom_auto, 'sshb'   , ssh(:,:,Kbb) ) 
     378         ! 
     379         !                                     !*  RK3: Set ssh at Kmm for AGRIF 
     380         ssh(:,:,Kmm) = 0._wp 
     381#else 
     382         !                                     !*  MLF: Read ssh at Kmm 
     383         IF(lwp) WRITE(numout,*) 
     384         IF(lwp) WRITE(numout,*)    '      Kmm sea surface height read in the restart file' 
     385         CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm) ) 
     386         ! 
     387         IF( l_1st_euler ) THEN                !*  MLF: Euler at first time-step 
     388            IF(lwp) WRITE(numout,*) 
     389            IF(lwp) WRITE(numout,*) '      Euler first time step : ssh(Kbb) = ssh(Kmm)' 
     390            ssh(:,:,Kbb) = ssh(:,:,Kmm) 
     391            ! 
     392         ELSE                                  !*  MLF: read ssh at Kbb 
     393            IF(lwp) WRITE(numout,*) 
     394            IF(lwp) WRITE(numout,*) '      Kbb sea surface height read in the restart file' 
     395            CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 
     396         ENDIF 
     397#endif 
     398         !                         !============================! 
     399      ELSE                         !==  Initialize at "rest"  ==! 
     400         !                         !============================! 
     401         ! 
     402         IF(lwp) WRITE(numout,*) 
     403         IF(lwp) WRITE(numout,*)    '      initialization at rest' 
     404         ! 
     405         IF( ll_wd ) THEN                      !* wet and dry  
     406            ! 
     407            IF( ln_read_cfg  ) THEN                 ! read configuration : ssh_ref is read in domain_cfg file 
     408!!st  why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), 
     409!!st  since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm 
     410               ssh(:,:,Kbb) = -ssh_ref 
     411               ! 
     412               DO_2D( 1, 1, 1, 1 ) 
     413                  IF( ht_0(ji,jj)-ssh_ref <  rn_wdmin1 ) THEN   ! if total depth is less than min depth 
     414                     ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) 
     415                  ENDIF 
     416               END_2D 
     417            ELSE                                    ! user define configuration case   
     418               CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 
     419            ENDIF 
     420            ! 
     421         ELSE                                  !* user defined configuration 
     422            CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 
     423            ! 
     424         ENDIF 
     425         ! 
     426#if defined key_RK3 
     427         ssh(:,:,Kmm) = 0._wp                  !* RK3: set Kmm to 0 for AGRIF 
     428#else 
     429         ssh(:,:,Kmm) = ssh(:,:,Kbb)           !* MLF: set now values from to before ones  
     430#endif 
     431      ENDIF 
     432      ! 
     433      !                            !==========================! 
     434      ssh(:,:,Kaa) = 0._wp         !==  Set to 0 for AGRIF  ==! 
     435      !                            !==========================! 
     436      ! 
     437   END SUBROUTINE rst_read_ssh 
    295438 
    296439   !!===================================================================== 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ISF/isfcpl.F90

    r14072 r14200  
    1515#if defined key_qco 
    1616   USE domqco  , ONLY : dom_qco_zgr      ! vertical scale factor interpolation 
     17#elif defined key_linssh 
     18   !                                     ! fix in time coordinate 
    1719#else 
    1820   USE domvvl  , ONLY : dom_vvl_zgr      ! vertical scale factor interpolation 
    … …  
    117119      vv   (:,:,:,Kbb)   = vv   (:,:,:,Kmm) 
    118120      ssh (:,:,Kbb)     = ssh (:,:,Kmm) 
    119 #if ! defined key_qco 
     121#if ! defined key_qco   &&   ! defined key_linssh 
    120122      e3t(:,:,:,Kbb)   = e3t(:,:,:,Kmm) 
    121123#endif 
    … …  
    217219      IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 
    218220      IF(lwp) write(numout,*) '~~~~~~~~~~~' 
    219 #if ! defined key_qco 
     221#if defined key_qco 
     222      CALL dom_qco_zgr(Kbb, Kmm) 
     223#elif defined key_linssh 
     224      ! linear ssh : fix in time coord. 
     225#else 
    220226      DO jk = 1, jpk 
    221227         e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) 
    … …  
    223229      e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    224230      CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 
    225 #else 
    226       CALL dom_qco_zgr(Kbb, Kmm) 
    227231#endif 
    228232      ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ISF/isfstp.F90

    r14064 r14200  
    8787            ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
    8888         END DO  
    89          CALL isf_tbl_lvl( ht(:,:), ze3t, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) 
     89         CALL isf_tbl_lvl( ht(:,:), ze3t           , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) 
    9090#else 
    91          CALL isf_tbl_lvl( ht(:,:),  e3t, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) 
     91         CALL isf_tbl_lvl( ht(:,:),  e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) 
    9292#endif 
    9393         ! 
    … …  
    116116            ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
    117117         END DO 
    118          CALL isf_tbl_lvl( ht(:,:), ze3t, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) 
     118         CALL isf_tbl_lvl( ht(:,:), ze3t           , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) 
    119119#else 
    120          CALL isf_tbl_lvl( ht(:,:),  e3t, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) 
     120         CALL isf_tbl_lvl( ht(:,:),  e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) 
    121121#endif 
    122122         ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/LDF/ldfc1d_c2d.F90

    r14072 r14200  
    140140         END_2D 
    141141      CASE( 'TRA' )                       ! U- and V-points 
    142          ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 
    143142         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    144143            pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/LDF/ldftra.F90

    r14072 r14200  
    427427         zaht_min = 0.2_wp * aht0                                       ! minimum value for aht 
    428428         zDaht    = aht0 - zaht_min 
    429          ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 
    430429         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    431430            !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/SBC/abl.F90

    • Property svn:executable deleted

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/SBC/sbcfwb.F90

    r13582 r14200  
    2424   ! 
    2525   USE in_out_manager ! I/O manager 
     26   USE iom            ! IOM 
    2627   USE lib_mpp        ! distribued memory computing library 
    2728   USE timing         ! Timing 
    … …  
    3435   PUBLIC   sbc_fwb    ! routine called by step 
    3536 
    36    REAL(wp) ::   a_fwb_b   ! annual domain averaged freshwater budget 
    37    REAL(wp) ::   a_fwb     ! for 2 year before (_b) and before year. 
    38    REAL(wp) ::   fwfold    ! fwfold to be suppressed 
     37   REAL(wp) ::   rn_fwb0   ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) 
     38   REAL(wp) ::   a_fwb     ! annual domain averaged freshwater budget from the 
     39                           ! previous year 
    3940   REAL(wp) ::   area      ! global mean ocean surface (interior domain) 
    4041 
    … …  
    6566      INTEGER, INTENT( in ) ::   Kmm      ! ocean time level index 
    6667      ! 
    67       INTEGER  ::   inum, ikty, iyear     ! local integers 
     68      INTEGER  ::   ios, inum, ikty       ! local integers 
    6869      REAL(wp) ::   z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp                ! local scalars 
    6970      REAL(wp) ::   zsurf_neg, zsurf_pos, zsurf_tospread, zcoef          !   -      - 
    … …  
    7273      REAL(wp)   ,DIMENSION(1) ::   z_fwfprv   
    7374      COMPLEX(dp),DIMENSION(1) ::   y_fwfnow   
     75      ! 
     76      NAMELIST/namsbc_fwb/rn_fwb0 
    7477      !!---------------------------------------------------------------------- 
    7578      ! 
    7679      IF( kt == nit000 ) THEN 
     80         READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 ) 
     81901      IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist'     ) 
     82         READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) 
     83902      IF( ios >  0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' ) 
     84         IF(lwm) WRITE( numond, namsbc_fwb ) 
    7785         IF(lwp) THEN 
    7886            WRITE(numout,*) 
    … …  
    8088            WRITE(numout,*) '~~~~~~~' 
    8189            IF( kn_fwb == 1 )   WRITE(numout,*) '          instantaneously set to zero' 
    82             IF( kn_fwb == 2 )   WRITE(numout,*) '          adjusted from previous year budget' 
    8390            IF( kn_fwb == 3 )   WRITE(numout,*) '          fwf set to zero and spread out over erp area' 
     91            IF( kn_fwb == 2 ) THEN 
     92               WRITE(numout,*) '          adjusted from previous year budget' 
     93               WRITE(numout,*) 
     94               WRITE(numout,*) '   Namelist namsbc_fwb' 
     95               WRITE(numout,*) '      Initial freshwater adjustment flux [kg/m2/s] = ', rn_fwb0 
     96            END IF 
    8497         ENDIF 
    8598         ! 
    … …  
    112125         ENDIF 
    113126         ! 
    114       CASE ( 2 )                             !==  fwf budget adjusted from the previous year  ==! 
    115          ! 
    116          IF( kt == nit000 ) THEN                      ! initialisation 
    117             !                                         ! Read the corrective factor on precipitations (fwfold) 
    118             CALL ctl_opn( inum, 'EMPave_old.dat', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 
    119             READ ( inum, "(24X,I8,2ES24.16)" ) iyear, a_fwb_b, a_fwb 
    120             CLOSE( inum ) 
    121             fwfold = a_fwb                            ! current year freshwater budget correction 
    122             !                                         ! estimate from the previous year budget 
     127      CASE ( 2 )                             !==  fw adjustment based on fw budget at the end of the previous year  ==! 
     128         ! 
     129         IF( kt == nit000 ) THEN                                                                    ! initialisation 
     130            !                                                                                       ! set the fw adjustment (a_fwb) 
     131            IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb',   ldstop = .FALSE. ) > 0 ) THEN        !    as read from restart file 
     132               IF(lwp) WRITE(numout,*) 'sbc_fwb : reading FW-budget adjustment from restart file' 
     133               CALL iom_get( numror, 'a_fwb',   a_fwb ) 
     134            ELSE                                                                                    !    as specified in namelist 
     135               a_fwb = rn_fwb0 
     136            END IF 
     137            ! 
    123138            IF(lwp)WRITE(numout,*) 
    124             IF(lwp)WRITE(numout,*)'sbc_fwb : year = ',iyear  , ' freshwater budget correction = ', fwfold 
    125             IF(lwp)WRITE(numout,*)'          year = ',iyear-1, ' freshwater budget read       = ', a_fwb 
    126             IF(lwp)WRITE(numout,*)'          year = ',iyear-2, ' freshwater budget read       = ', a_fwb_b 
     139            IF(lwp)WRITE(numout,*)'sbc_fwb : initial freshwater-budget adjustment = ', a_fwb, 'kg/m2/s' 
     140            ! 
    127141         ENDIF    
    128          !                                         ! Update fwfold if new year start 
     142         !                                         ! Update a_fwb if new year start 
    129143         ikty = 365 * 86400 / rn_Dt                  !!bug  use of 365 days leap year or 360d year !!!!!!! 
    130144         IF( MOD( kt, ikty ) == 0 ) THEN 
    131             a_fwb_b = a_fwb                           ! mean sea level taking into account the ice+snow 
     145                                                      ! mean sea level taking into account the ice+snow 
    132146                                                      ! sum over the global domain 
    133147            a_fwb   = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) 
    134148            a_fwb   = a_fwb * 1.e+3 / ( area * rday * 365. )     ! convert in Kg/m3/s = mm/s 
    135149!!gm        !                                                      !!bug 365d year  
    136             fwfold =  a_fwb                           ! current year freshwater budget correction 
    137             !                                         ! estimate from the previous year budget 
    138150         ENDIF 
    139151         !  
    140152         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN         ! correct the freshwater fluxes 
    141             zcoef = fwfold * rcp 
    142             emp(:,:) = emp(:,:) + fwfold             * tmask(:,:,1) 
     153            zcoef = a_fwb * rcp 
     154            emp(:,:) = emp(:,:) + a_fwb              * tmask(:,:,1) 
    143155            qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 
    144156         ENDIF 
    145          ! 
    146          IF( kt == nitend .AND. lwm ) THEN            ! save fwfold value in a file (only one required) 
    147             CALL ctl_opn( inum, 'EMPave.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    148             WRITE( inum, "(24X,I8,2ES24.16)" ) nyear, a_fwb_b, a_fwb 
    149             CLOSE( inum ) 
    150          ENDIF 
     157         ! Output restart information 
     158         IF( lrst_oce ) THEN 
     159            IF(lwp) WRITE(numout,*) 
     160            IF(lwp) WRITE(numout,*) 'sbc_fwb : writing FW-budget adjustment to ocean restart file at it = ', kt 
     161            IF(lwp) WRITE(numout,*) '~~~~' 
     162            CALL iom_rstput( kt, nitrst, numrow, 'a_fwb',   a_fwb ) 
     163         END IF 
     164         ! 
     165         IF( kt == nitend .AND. lwp ) WRITE(numout,*) 'sbc_fwb : final freshwater-budget adjustment = ', a_fwb, 'kg/m2/s' 
    151166         ! 
    152167      CASE ( 3 )                             !==  global fwf set to zero and spread out over erp area  ==! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/eosbn2.F90

    r14072 r14200  
    8989 
    9090   !                               !!!  simplified eos coefficients (default value: Vallis 2006) 
    91    REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff. 
    92    REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff. 
     91   REAL(wp), PUBLIC ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff. 
     92   REAL(wp), PUBLIC ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff. 
    9393   REAL(wp) ::   rn_lambda1 = 5.9520e-2_wp     ! cabbeling coeff. in T^2 
    9494   REAL(wp) ::   rn_lambda2 = 5.4914e-4_wp     ! cabbeling coeff. in S^2 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traadv.F90

    r14090 r14200  
    175175         ENDIF 
    176176         ! 
    177          ! NOTE: [tiling-comms-merge] These lbc_lnk calls are still needed (pts in the zco case because zps_hde is not called in step, zuu/zvv/zww in all cases, I think because DO loop bounds need to be updated in DYN as done in TRA) 
    178177         SELECT CASE ( nadv )                      !==  compute advection trend and add it to general trend  ==! 
    179178         ! 
    … …  
    194193            END IF 
    195194         CASE ( np_MUS )                                 ! MUSCL 
    196             ! NOTE: [tiling-comms-merge] I added this lbc_lnk as it did not validate against the trunk when using ln_zco 
    197195            IF (nn_hls.EQ.2) THEN 
    198196                CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traadv_fct.F90

    r14072 r14200  
    8282      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
    8383      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    84       ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 
    8584      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    8685      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    102101            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    103102         ENDIF 
    104          ! NOTE: [tiling-comms-merge] Bug fix- move array zeroing out of this IF block 
    105103         ! 
    106104         l_trd = .FALSE.            ! set local switches 
    … …  
    353351            END_3D 
    354352         END IF 
    355          ! NOTE: [tiling-comms-merge] I tested this 
    356          ! NOT TESTED - NEED l_trd OR l_hst TRUE 
    357353         IF( l_trd .OR. l_hst ) THEN   ! trend diagnostics // heat/salt transport 
    358354            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes 
    … …  
    369365            ! 
    370366         ENDIF 
    371          ! NOTE: [tiling-comms-merge] I tested this 
    372          ! NOT TESTED - NEED l_ptr TRUE 
    373367         IF( l_ptr ) THEN              ! "Poleward" transports 
    374368            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< add anti-diffusive fluxes 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traadv_qck.F90

    r14072 r14200  
    9292      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
    9393      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    94       ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 
    9594      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
    9695      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/trabbl.F90

    r14072 r14200  
    141141         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
    142142            ! lateral boundary conditions ; just need for outputs 
    143             ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
    144143            CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
    145144            CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
    … …  
    249248      DO jn = 1, kjpt                                            ! tracer loop 
    250249         !                                                       ! =========== 
    251          ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices 
    252250         DO_2D( isj, 0, isi, 0 )            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
    253251            IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traldf.F90

    r14090 r14200  
    9292            CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
    9393         CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators 
    94             ! NOTE: [tiling-comms-merge] This lbc_lnk is still needed in the zco case, because zps_hde is not called in step 
    9594            IF(nn_hls.EQ.2) CALL lbc_lnk( 'tra_ldf', pts(:,:,:,:,Kbb), 'T',1.) 
    9695            CALL tra_ldf_blp  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),             jpts, nldf_tra ) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traldf_lap_blp.F90

    r14072 r14200  
    158158         ENDIF 
    159159         ! 
    160          ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 
    161160         DO_3D( isj, iej, isi, iei, 1, jpkm1 )            !== Second derivative (divergence) added to the general tracer trends  ==! 
    162161            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    … …  
    236235      END SELECT 
    237236      ! 
    238       ! NOTE: [tiling-comms-merge] Needed for both nn_hls as tra_ldf_iso and tra_ldf_triad have not yet been adjusted to work with nn_hls = 2. In the zps case the lbc_lnk in zps_hde handles this, but in the zco case zlap always needs this lbc_lnk. I did try adjusting the bounds in tra_ldf_iso and tra_ldf_triad so this lbc_lnk was only needed for nn_hls = 1, but this was not correct and I did not have time to figure out why 
    239237      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp )     ! Lateral boundary conditions (unchanged sign) 
    240238      !                                               ! Partial top/bottom cell: GRADh( zlap ) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/tranpc.F90

    r14090 r14200  
    112112         IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 
    113113         ! 
    114          ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 
    115114         DO_2D( isj, iej, isi, iei )                        ! interior column only 
    116115            ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traqsr.F90

    r14090 r14200  
    137137      !                         !  before qsr induced heat content  ! 
    138138      !                         !-----------------------------------! 
    139       ! NOTE: [tiling-comms-merge] Many DO loop bounds changed (probably more than necessary) to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 
    140139      IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
    141140      IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/trasbc.F90

    r14072 r14200  
    9898      ENDIF 
    9999      ! 
    100       ! NOTE: [tiling-comms-merge] Many DO loop bounds changed to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 
    101100      IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
    102101      IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 
    … …  
    155154      ! 
    156155      DO jn = 1, jpts               !==  update tracer trend  ==! 
    157          ! NOTE: [tiling-comms-merge] This looped over nn_hls, which changes the results when using tiling 
    158156         DO_2D( 0, 0, 0, 0 ) 
    159157            pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) )    & 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/trazdf.F90

    r14072 r14200  
    2323   USE trd_oce        ! trends: ocean variables 
    2424   USE trdtra         ! trends: tracer trend manager 
     25   USE eosbn2, ONLY: ln_SEOS, rn_b0 
    2526   ! 
    2627   USE in_out_manager ! I/O manager 
    … …  
    8384      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    8485      ! JMM : restore negative salinities to small salinities: 
    85       WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp )   pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 
     86!!jc: discard this correction in case salinity is not used in eos 
     87      IF ( .NOT.(ln_SEOS.AND.(rn_b0==0._wp)) ) THEN 
     88         WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp )   pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 
     89      ENDIF 
    8690!!gm 
    8791 
    … …  
    97101               &          - ztrds(:,:,jk) 
    98102         END DO 
    99          ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
    100103!!gm this should be moved in trdtra.F90 and done on all trends 
    101104         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/zpshde.F90

    r14072 r14200  
    124124      ! 
    125125      IF( ln_timing )   CALL timing_start( 'zps_hde') 
    126       ! NOTE: [tiling-comms-merge] Some lbc_lnks in tra_adv and tra_ldf can be taken out in the zps case, because this lbc_lnk is called when zps_hde is called in the stp routine. In the zco case they are still needed. 
    127126      IF (nn_hls.EQ.2) THEN 
    128127         CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRD/trdtra.F90

    r13497 r14200  
    9191      IF( .NOT. ALLOCATED( trdtx ) ) THEN      ! allocate trdtra arrays 
    9292         IF( trd_tra_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) 
     93         avt_evd(:,:,:) = 0._wp 
    9394      ENDIF 
    9495      ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ZDF/zdfgls.F90

    r14072 r14200  
    187187      IF( .NOT.ln_drg_OFF ) THEN     !== top/bottom friction   (explicit before friction) 
    188188         DO_2D( 0, 0, 0, 0 )         ! bottom friction (explicit before friction) 
    189             zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
    190             zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
     189            zmsku = 0.5_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
     190            zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
    191191            ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2  & 
    192192               &                                         + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2  ) 
    … …  
    194194         IF( ln_isfcav ) THEN 
    195195            DO_2D( 0, 0, 0, 0 )      ! top friction 
    196                zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
    197                zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
     196               zmsku = 0.5_wp * ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
     197               zmskv = 0.5_wp * ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
    198198               ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2  & 
    199199                  &                                         + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2  ) 
    … …  
    396396            zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 
    397397            zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp 
     398            en   (ji,jj,ibot) = z_en 
    398399         END_2D 
    399400         IF( ln_isfcav) THEN     ! top boundary   (ocean cavity) 
    … …  
    410411               zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 
    411412               zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp 
     413               en   (ji,jj,itop) = z_en 
    412414            END_2D 
    413415         ENDIF 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/nemogcm.F90

    r14086 r14200  
    5151   USE istate         ! initial state setting          (istate_init routine) 
    5252   USE trdini         ! dyn/tra trends initialization     (trd_init routine) 
    53    USE asminc         ! assimilation increments      
    54    USE asmbkg         ! writing out state trajectory 
    55    USE diadct         ! sections transports           (dia_dct_init routine) 
    56    USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
    57    USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    58    USE diamlr         ! IOM context management for multiple-linear-regression analysis 
    59 #if defined key_qco 
    60    USE stepMLF        ! NEMO time-stepping               (stp_MLF   routine) 
    61 #else 
    62    USE step           ! NEMO time-stepping                 (stp     routine) 
    63 #endif 
    64    USE isfstp         ! ice shelf                     (isf_stp_init routine) 
    6553   USE icbini         ! handle bergs, initialisation 
    6654   USE icbstp  , ONLY : icb_end     ! handle bergs, close iceberg files 
    … …  
    7866   USE ice_domain_size, only: nx_global, ny_global 
    7967#endif 
    80 #if defined key_qco 
     68#if defined key_qco   ||   defined key_linssh 
    8169   USE stpmlf         ! NEMO time-stepping               (stp_MLF   routine) 
    8270#else 
    … …  
    8876   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges 
    8977   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    90 #if defined key_iomput 
    91    USE xios           ! xIOserver 
    92 #endif 
    93 #if defined key_agrif 
    94    USE agrif_all_update   ! Master Agrif update 
    95    USE agrif_oce_update 
    96 #endif 
    97    USE halo_mng 
     78   USE halo_mng       ! halo manager 
    9879 
    9980   IMPLICIT NONE 
    … …  
    180161      ! 
    181162      DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    182 #  if defined key_qco 
     163         ! 
     164#  if defined key_qco   ||   defined key_linssh 
    183165         CALL stp_MLF 
    184166#  else 
    … …  
    201183            ENDIF 
    202184            ! 
    203 #  if defined key_qco 
    204             CALL stp_MLF      ( istp ) 
     185#  if defined key_qco   ||   defined key_linssh 
     186            CALL stp_MLF( istp ) 
    205187#  else 
    206             CALL stp        ( istp ) 
     188            CALL stp    ( istp ) 
    207189#  endif 
    208190            istp = istp + 1 
    … …  
    348330      IF(lwp) THEN                      ! open listing units 
    349331         ! 
    350          IF( .NOT.lwm )   &            ! alreay opened for narea == 1 
     332         IF( .NOT. lwm )   &            ! alreay opened for narea == 1 
    351333            &            CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 
    352334         ! 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/step.F90

    r14072 r14200  
    3333   !!            4.1  !  2019-08  (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme 
    3434   !!---------------------------------------------------------------------- 
    35 #if defined key_qco 
    36    !!---------------------------------------------------------------------- 
    37    !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     35#if defined key_qco   ||   defined key_linssh 
     36   !!---------------------------------------------------------------------- 
     37   !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordinate 
     38   !!                                OR 
     39   !!   'key_linssh    EMPTY MODULE       Fixed in time vertical coordinate 
    3840   !!---------------------------------------------------------------------- 
    3941#else 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/step_oce.F90

    r14090 r14200  
    110110   USE agrif_oce_sponge ! Momemtum and tracers sponges 
    111111   USE agrif_all_update ! Main update driver 
     112   USE agrif_oce_update 
    112113#endif 
    113114#if defined key_top 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/stpctl.F90

    r14053 r14200  
    1515   !!---------------------------------------------------------------------- 
    1616   !!   stp_ctl      : Control the run 
     17   !!   stp_ctl_SWE  : Control the run (SWE only) 
    1718   !!---------------------------------------------------------------------- 
    1819   USE oce             ! ocean dynamics and tracers variables 
    … …  
    2627   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2728   USE lib_mpp         ! distributed memory computing 
     29   USE eosbn2, ONLY: ln_SEOS, rn_b0 
     30   ! 
    2831   USE netcdf          ! NetCDF library 
    29  
    3032   IMPLICIT NONE 
    3133   PRIVATE 
    3234 
    3335   PUBLIC stp_ctl           ! routine called by step.F90 
     36   PUBLIC stp_ctl_SWE       ! routine called by stpmlf.F90 
    3437 
    3538   INTEGER                ::   nrunid   ! netcdf file id 
    3639   INTEGER, DIMENSION(8)  ::   nvarid   ! netcdf variable id 
     40   INTEGER, DIMENSION(2)  ::   nvarid_SWE   ! netcdf variable id (SWE only) 
    3741   !!---------------------------------------------------------------------- 
    3842   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6569      INTEGER , DIMENSION(9)          ::   iareasum, iareamin, iareamax 
    6670      INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
    67       REAL(wp)                        ::   zzz                                   ! local real  
     71      REAL(wp)                        ::   zzz, zminsal, zmaxsal                 ! local real  
    6872      REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal 
    6973      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 
    … …  
    7175      CHARACTER(len=20)               ::   clname 
    7276      !!---------------------------------------------------------------------- 
    73       ! 
    7477      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
    7578      ! 
    … …  
    180183         END DO 
    181184         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    182       ENDIF 
     185      END IF 
    183186      !                                   !==               error handling               ==! 
    184187      !                                   !==  done by all processes at every time step  ==! 
    185188      ! 
     189      IF ( ln_SEOS.AND.(rn_b0==0._wp) ) THEN             ! Discard checks on salinity 
     190         zmaxsal = +1.e38                                ! if not used in eos 
     191         zminsal = -1.e38  
     192      ELSE 
     193         zmaxsal = 100._wp 
     194         zminsal =   0._wp 
     195      ENDIF  
     196      !  
    186197      IF(  zmax(1) >   20._wp .OR.   &                   ! too large sea surface height ( > 20 m ) 
    187198         & zmax(2) >   10._wp .OR.   &                   ! too large velocity ( > 10 m/s) 
    188          & zmax(3) <=   0._wp .OR.   &                   ! negative or zero sea surface salinity 
    189          & zmax(4) >= 100._wp .OR.   &                   ! too large sea surface salinity ( > 100 ) 
    190          & zmax(4) <    0._wp .OR.   &                   ! too large sea surface salinity (keep this line for sea-ice) 
     199         & zmax(3) <= zminsal .OR.   &                   ! negative or zero sea surface salinity 
     200         & zmax(4) >= zmaxsal .OR.   &                   ! too large sea surface salinity ( > 100 ) 
     201         & zmax(4) <  zminsal .OR.   &                   ! too large sea surface salinity (keep this line for sea-ice) 
    191202         & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR.   &               ! NaN encounter in the tests 
    192203         & ABS(   zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
    … …  
    262273 
    263274 
     275   SUBROUTINE stp_ctl_SWE( kt, Kmm ) 
     276      !!---------------------------------------------------------------------- 
     277      !!                    ***  ROUTINE stp_ctl_SWE  *** 
     278      !!                      
     279      !! ** Purpose :   Control the run 
     280      !! 
     281      !! ** Method  : - Save the time step in numstp 
     282      !!              - Print it each 50 time steps 
     283      !!              - Stop the run IF problem encountered by setting nstop > 0 
     284      !!                Problems checked: e3t0+ssh minimum smaller that 0 
     285      !!                                  |U|   maximum larger than 10 m/s  
     286      !!                                  ( not for SWE : negative sea surface salinity ) 
     287      !! 
     288      !! ** Actions :   "time.step" file = last ocean time-step 
     289      !!                "run.stat"  file = run statistics 
     290      !!                 nstop indicator sheared among all local domain 
     291      !!---------------------------------------------------------------------- 
     292      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
     293      INTEGER, INTENT(in   ) ::   Kmm      ! ocean time level index 
     294      !! 
     295      INTEGER                         ::   ji                                    ! dummy loop indices 
     296      INTEGER                         ::   idtime, istatus 
     297      INTEGER , DIMENSION(3)          ::   iareasum, iareamin, iareamax 
     298      INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
     299      REAL(wp)                        ::   zzz                                   ! local real  
     300      REAL(wp), DIMENSION(3)          ::   zmax, zmaxlocal 
     301      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 
     302      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
     303      CHARACTER(len=20)               ::   clname 
     304      !!---------------------------------------------------------------------- 
     305      ! 
     306      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
     307      ! 
     308      ll_wrtstp  = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 
     309      ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1  
     310      ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm 
     311      ! 
     312      IF( kt == nit000 ) THEN 
     313         ! 
     314         IF( lwp ) THEN 
     315            WRITE(numout,*) 
     316            WRITE(numout,*) 'stp_ctl_SWE : time-stepping control' 
     317            WRITE(numout,*) '~~~~~~~~~~~' 
     318         ENDIF 
     319         !                                ! open time.step    ascii file, done only by 1st subdomain 
     320         IF( lwm )   CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     321         ! 
     322         IF( ll_wrtruns ) THEN 
     323            !                             ! open run.stat     ascii file, done only by 1st subdomain 
     324            CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     325            !                             ! open run.stat.nc netcdf file, done only by 1st subdomain 
     326            clname = 'run.stat.nc' 
     327            IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
     328            istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) 
     329            istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime ) 
     330            istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid_SWE(1) ) 
     331            istatus = NF90_DEF_VAR( nrunid,   'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid_SWE(2) ) 
     332            istatus = NF90_ENDDEF(nrunid) 
     333         ENDIF 
     334         !     
     335      ENDIF 
     336      ! 
     337      !                                   !==              write current time step              ==! 
     338      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
     339      IF( lwm .AND. ll_wrtstp ) THEN 
     340         WRITE ( numstp, '(1x, i8)' )   kt 
     341         REWIND( numstp ) 
     342      ENDIF 
     343      !                                   !==            test of local extrema           ==! 
     344      !                                   !==  done by all processes at every time step  ==! 
     345      ! 
     346      llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
     347      llmsk(Nie1: jpi,:,:) = .FALSE. 
     348      llmsk(:,   1:Njs1,:) = .FALSE. 
     349      llmsk(:,Nje1: jpj,:) = .FALSE. 
     350      ! 
     351      llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp         ! define only the inner domain 
     352      ! 
     353      ll_0oce = .NOT. ANY( llmsk(:,:,1) )                                         ! no ocean point in the inner domain? 
     354      ! 
     355      zmax(1) = MINVAL( -e3t_0(:,:,1)-ssh(:,:,Kmm)  , mask = llmsk(:,:,1)  )       ! e3t_Kmm min 
     356      ! 
     357      llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     358      zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) )      , mask = llmsk(:,:,:) )        ! velocity max (zonal only) 
     359      zmax(3) = REAL( nstop , wp )                                                ! stop indicator 
     360 
     361      !                                   !==               get global extrema             ==! 
     362      !                                   !==  done by all processes if writting run.stat  ==! 
     363      IF( ll_colruns ) THEN 
     364         zmaxlocal(:) = zmax(:) 
     365         CALL mpp_max( "stpctl", zmax )          ! max over the global domain 
     366         nstop = NINT( zmax(3) )                 ! update nstop indicator (now sheared among all local domains) 
     367      ELSE 
     368         ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 
     369         IF( ll_0oce )   zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /)   ! default "valid" values... 
     370      ENDIF 
     371      ! 
     372      zmax(1) = -zmax(1)                         ! move back from max(-zz) to min(zz) : easier to manage! 
     373      ! 
     374      !                                   !==              write "run.stat" files              ==! 
     375      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
     376      IF( ll_wrtruns ) THEN 
     377         WRITE(numrun,9500) kt, zmax(1), zmax(2) 
     378         istatus = NF90_PUT_VAR( nrunid, nvarid_SWE(1), (/ zmax(1)/), (/kt/), (/1/) ) 
     379         istatus = NF90_PUT_VAR( nrunid, nvarid_SWE(2), (/ zmax(2)/), (/kt/), (/1/) ) 
     380         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
     381      ENDIF 
     382      !                                   !==               error handling               ==! 
     383      !                                   !==  done by all processes at every time step  ==! 
     384      ! 
     385!!SWE specific : start 
     386      IF(   zmax(1) <=   0._wp .OR.           &               ! negative e3t_Kmm 
     387         &  zmax(2) >   10._wp .OR.           &               ! too large velocity ( > 10 m/s) 
     388         &  ISNAN( zmax(1) + zmax(2) ) .OR.   &               ! NaN encounter in the tests 
     389         &  ABS(   zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
     390         ! 
     391         iloc(:,:) = 0 
     392         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
     393            ! first: close the netcdf file, so we can read it 
     394            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
     395            ! get global loc on the min/max 
     396            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp         ! define only the inner domain 
     397            CALL mpp_minloc( 'stpctl', e3t_0(:,:,1) + ssh(:,:,Kmm), llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F 
     398            llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     399            CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,Kmm))        , llmsk(:,:,:), zzz, iloc(1:3,2) ) 
     400            ! find which subdomain has the max. 
     401            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
     402            DO ji = 1, 3 
     403               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     404                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     405               ENDIF 
     406            END DO 
     407            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     408            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     409            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
     410         ELSE                    ! find local min and max locations: 
     411            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
     412            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp        ! define only the inner domain 
     413            iloc(1:2,1) = MINLOC( e3t_0(:,:,1) + ssh(:,:,Kmm), mask = llmsk(:,:,1) ) 
     414            ! 
     415            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     416            iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask = llmsk(:,:,:) ) 
     417            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
     418         ENDIF 
     419         ! 
     420         WRITE(ctmp1,*) ' stp_ctl_SWE:  e3t0+ssh < 0 m  or  |U| > 10 m/s  or  NaN encounter in the tests' 
     421         CALL wrt_line( ctmp2, kt, 'e3t0+ssh min',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     422         CALL wrt_line( ctmp3, kt, '|U|   max'   ,  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     423         IF( Agrif_Root() ) THEN 
     424            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
     425         ELSE 
     426            WRITE(ctmp6,*) '      ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files' 
     427         ENDIF 
     428         ! 
     429         CALL dia_wri_state( Kmm, 'output.abort' )     ! create an output.abort file 
     430         ! 
     431         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
     432            IF(lwp) THEN   ;   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
     433            ELSE           ;   nstop = MAX(1, nstop)   ! make sure nstop > 0 (automatically done when calling ctl_stop) 
     434            ENDIF 
     435         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
     436            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
     437         ENDIF 
     438         ! 
     439      ENDIF 
     440!!SWE specific : end 
     441      ! 
     442      IF( nstop > 0 ) THEN                                                  ! an error was detected and we did not abort yet... 
     443         ngrdstop = Agrif_Fixed()                                           ! store which grid got this error 
     444         IF( .NOT. ll_colruns .AND. jpnij > 1 )   CALL ctl_stop( 'STOP' )   ! we must abort here to avoid MPI deadlock 
     445      ENDIF 
     446      ! 
     4479500  FORMAT(' it :', i8, '      e3t_min: ', D23.16, ' |U|_max: ', D23.16) 
     448      ! 
     449   END SUBROUTINE stp_ctl_SWE 
     450 
     451 
    264452   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
    265453      !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/stpmlf.F90

    r14053 r14200  
    3636   !!---------------------------------------------------------------------- 
    3737 
    38 #if defined key_qco 
    39    !!---------------------------------------------------------------------- 
    40    !!   'key_qco'       Quasi-Eulerian vertical coordonate 
    41    !!---------------------------------------------------------------------- 
    42     
    43    !!---------------------------------------------------------------------- 
    44    !!   stp_MLF       : NEMO modified Leap Frog time-stepping with qco 
     38#if defined key_qco   ||   defined key_linssh 
     39   !!---------------------------------------------------------------------- 
     40   !!   'key_qco'                        Quasi-Eulerian vertical coordinate 
     41   !!                          OR 
     42   !!   'key_linssh                       Fixed in time vertical coordinate 
     43   !!---------------------------------------------------------------------- 
     44 
     45   !!---------------------------------------------------------------------- 
     46   !!   stp_MLF       : NEMO modified Leap Frog time-stepping with qco or linssh 
    4547   !!---------------------------------------------------------------------- 
    4648   USE step_oce       ! time stepping definition modules 
    … …  
    196198      END DO 
    197199                            CALL ssh_nxt    ( kstp, Nbb, Nnn, ssh,  Naa )   ! after ssh (includes call to div_hor) 
    198       IF( .NOT.ln_linssh )  THEN 
     200      IF( .NOT.lk_linssh )  THEN 
    199201                             CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa)           )   ! "after" ssh/h_0 ratio at t,u,v pts 
    200202         IF( ln_dynspg_exp ) CALL dom_qco_r3c( ssh(:,:,Nnn), r3t(:,:,Nnn), r3u(:,:,Nnn), r3v(:,:,Nnn), r3f(:,:) )   ! spg_exp : needed only for "now" ssh/h_0 ratio at f point 
    … …  
    225227      IF( ln_dynspg_ts ) THEN                         ! vertical scale factors and vertical velocity need to be updated 
    226228                            CALL div_hor    ( kstp, Nbb, Nnn )                ! Horizontal divergence  (2nd call in time-split case) 
    227          IF(.NOT.ln_linssh) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) )   ! update ssh/h_0 ratio at t,u,v,f pts  
     229         IF(.NOT.lk_linssh) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) )   ! update ssh/h_0 ratio at t,u,v,f pts  
    228230      ENDIF 
    229231                            CALL dyn_zdf    ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa  )  ! vertical diffusion 
    … …  
    257259      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    258260                         CALL ssh_atf    ( kstp, Nbb, Nnn, Naa, ssh )            ! time filtering of "now" sea surface height 
    259                         CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f )   ! "now" ssh/h_0 ratio from filtrered ssh 
     261      IF(.NOT.lk_linssh) CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f )   ! "now" ssh/h_0 ratio from filtrered ssh 
    260262#if defined key_top 
    261263      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    311313                         CALL finalize_lbc  ( kstp, Nbb     , Naa, uu, vv, ts )   ! boundary conditions 
    312314                         CALL tra_atf_qco   ( kstp, Nbb, Nnn, Naa        , ts )   ! time filtering of "now" tracer arrays 
    313                          CALL dyn_atf_qco   ( kstp, Nbb, Nnn, Naa, uu, vv     )   ! time filtering of "now" velocities  
     315                         CALL dyn_atf_qco   ( kstp, Nbb, Nnn, Naa, uu, vv     )   ! time filtering of "now" velocities 
     316      IF(.NOT.lk_linssh) THEN 
    314317                         r3t(:,:,Nnn) = r3t_f(:,:)                                ! update now ssh/h_0 with time filtered values 
    315318                         r3u(:,:,Nnn) = r3u_f(:,:) 
    316319                         r3v(:,:,Nnn) = r3v_f(:,:) 
     320      ENDIF 
    317321 
    318322      ! 
    … …  
    367371      IF( kstp == nitend .OR. indic < 0 ) THEN 
    368372                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    369          IF( lrxios ) CALL iom_context_finalize(      crxios_context          ) 
    370373         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 
    371374      ENDIF 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/nemogcm.F90

    r14053 r14200  
    3333   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges  
    3434   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    35    USE halo_mng       ! Halo manager 
     35   USE halo_mng       ! halo manager 
    3636 
    3737   IMPLICIT NONE 
    … …  
    127127      IF( nstop /= 0 .AND. lwp ) THEN        ! error print 
    128128         WRITE(ctmp1,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found' 
    129          CALL ctl_stop( ctmp1 ) 
     129         WRITE(ctmp2,*) '           Look for "E R R O R" messages in all existing ocean_output* files' 
     130         CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) 
    130131      ENDIF 
    131132      ! 
    … …  
    216217         WRITE(numout,*) '                       NEMO team' 
    217218         WRITE(numout,*) '            Ocean General Circulation Model' 
    218          WRITE(numout,*) '                NEMO version 4.0  (2019) ' 
     219         WRITE(numout,*) '                NEMO version 4.0  (2020) ' 
     220         WRITE(numout,*) 
     221         WRITE(numout,*) '                 Shallow Water Equation' 
     222         WRITE(numout,*) '                 ======================' 
    219223         WRITE(numout,*) 
    220224         WRITE(numout,*) "           ._      ._      ._      ._      ._    " 
    … …  
    232236         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    233237         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" 
     238         ! 
     239         WRITE(numout,cform_aaa)    ! Flag AAAAAAA 
     240         ! 
     241         !                          ! Control print of the working precision 
     242         WRITE(numout,*) 
     243         IF( wp == dp ) THEN   ;   WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" 
     244         ELSE                  ;   WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" 
    240245         ENDIF 
    241          WRITE(numout,*) 
    242          ! 
    243          WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 
     246                                   WRITE(numout,*) "~~~~~~~~                                 ****************" 
     247                                   WRITE(numout,*) 
    244248         ! 
    245249      ENDIF 
    … …  
    280284      !                             !-------------------------------! 
    281285 
    282       CALL nemo_ctl                          ! Control prints 
     286      CALL nemo_ctl                          ! Control prints of namctl and namcfg 
    283287      ! 
    284288      !                                      ! General initialization 
    … …  
    429433   END SUBROUTINE nemo_alloc 
    430434 
    431     
     435 
    432436   SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 
    433437      !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/stp_oce.F90

    r14053 r14200  
    9393   !                                                   (dyn_asm_inc routine) 
    9494   USE asmbkg          ! writing out state trajectory 
    95    USE stpctl          ! time stepping control            (stp_ctl routine) 
     95   USE stpctl          ! time stepping control            (stp_ctl_SWE routine) 
    9696   USE restart         ! ocean restart                    (rst_wri routine) 
    9797   USE prtctl          ! Print control                    (prt_ctl routine) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/stpmlf.F90

    r14053 r14200  
    7070      ENDIF 
    7171 
    72       IF( kstp == nit000 )   ww(:,:,:) = 0._wp   ! initialize vertical velocity one for all to zero 
     72      IF( kstp == nit000 )   ww(:,:,:) = 0._wp   ! initialize vertical velocity once for all to zero 
    7373 
    7474      ! 
    … …  
    222222      ! Control 
    223223      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    224                          CALL stp_ctl      ( kstp, Nnn ) 
     224                         CALL stp_ctl_SWE   ( kstp, Nnn ) 
    225225 
    226226      IF( kstp == nit000 ) THEN                          ! 1st time step only 
    … …  
    235235!!st : cxios_context needed ? because opened earlier ???          
    236236         CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 
    237 !!st : crxios_context not needed associated with coarsening !  
    238          IF(lrxios) CALL iom_context_finalize( crxios_context ) 
    239237      ENDIF 
    240238#endif 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/stprk3.F90

    r14053 r14200  
    129129      CALL dyn_ldf( kstp, Nbb, Nbb, uu, vv, Nrhs )  ! lateral mixing 
    130130#endif 
    131 !!st       ! 
    132 !!st       DO_3D( 0,0, 0,0, 1,jpkm1 ) 
    133 !!st          !                                          ! horizontal pressure gradient 
    134 !!st          uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nbb) - ssh(ji,jj,Nbb) ) * r1_e1u(ji,jj) 
    135 !!st          vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nbb) - ssh(ji,jj,Nbb) ) * r1_e2v(ji,jj) 
    136 !!st       END_3D 
    137 !!st       ! 
    138 !!st #if defined key_RK3all  
    139 !!st       !                                             ! wind stress and layer friction 
    140 !!st       z5_6 = 5._wp/6._wp 
    141 !!st       DO_3D( 0, 0, 0, 0,1,jpkm1) 
    142 !!st          uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + r1_rho0 * ( z5_6*utau_b(ji,jj) + (1._wp - z5_6)*utau(ji,jj) ) / e3u(ji,jj,jk,Nbb)   & 
    143 !!st             &                                  - rn_rfr * uu(ji,jj,jk,Nbb) 
    144 !!st          vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + r1_rho0 * ( z5_6*vtau_b(ji,jj) + (1._wp - z5_6)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nbb)   & 
    145 !!st             &                                  - rn_rfr * vv(ji,jj,jk,Nbb) 
    146 !!st       END_3D 
    147 !!st #endif 
    148 !!st why not ? 
    149131      z5_6 = 5._wp/6._wp 
    150132      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    … …  
    163145         vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + zrhs_v 
    164146      END_3D 
    165 !!st end 
    166147      ! 
    167148      !                                 !==  Time stepping of ssh Eq.  ==!   (and update r3_Naa) 
    … …  
    229210         vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + zrhs_v 
    230211      END_3D 
    231 !!st       ! 
    232 !!st       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    233 !!st          !                                          ! horizontal pressure gradient 
    234 !!st          uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj) 
    235 !!st          vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj) 
    236 !!st       END_3D 
    237 !!st       ! 
    238 !!st #if defined key_RK3all 
    239 !!st       !                                             ! wind stress and layer friction 
    240 !!st       z3_4 = 3._wp/4._wp 
    241 !!st       DO_3D( 0, 0, 0, 0,1,jpkm1) 
    242 !!st          uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + r1_rho0 * ( z3_4*utau_b(ji,jj) + (1._wp - z3_4)*utau(ji,jj) ) / e3u(ji,jj,jk,Nbb)   & 
    243 !!st             &                                  - rn_rfr * uu(ji,jj,jk,Nbb) 
    244 !!st          vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + r1_rho0 * ( z3_4*vtau_b(ji,jj) + (1._wp - z3_4)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nbb)   & 
    245 !!st             &                                  - rn_rfr * vv(ji,jj,jk,Nbb) 
    246 !!st       END_3D 
    247 !!st #endif 
    248212      ! 
    249213      !                                 !==  Time stepping of ssh Eq.  ==!   (and update r3_Naa) 
    … …  
    344308 
    345309      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    346       ! diagnostics and outputs 
     310      ! diagnostics and outputs at Nbb (i.e. the just computed time step) 
    347311      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    348312       
    349       IF( ln_diacfl  )   CALL dia_cfl   ( kstp,      Nnn )      ! Courant number diagnostics 
    350                          CALL dia_wri   ( kstp,      Nnn )      ! ocean model: outputs 
    351       ! 
    352       IF( lrst_oce   )   CALL rst_write    ( kstp, Nbb, Nnn )   ! write output ocean restart file 
     313      IF( ln_diacfl  )   CALL dia_cfl      ( kstp,      Nbb )      ! Courant number diagnostics 
     314                         CALL dia_wri      ( kstp,      Nbb )      ! ocean model: outputs 
     315      ! 
     316      IF( lrst_oce   )   CALL rst_write    ( kstp, Nbb, Nbb )   ! write output ocean restart file 
    353317 
    354318      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    355319      ! Control 
    356320      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    357                          CALL stp_ctl      ( kstp, Nnn ) 
     321                         CALL stp_ctl_SWE  ( kstp     , Nbb ) 
    358322 
    359323      IF( kstp == nit000 ) THEN                          ! 1st time step only 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/TOP/AGE/trcsms_age.F90

    r12377 r14200  
    5656      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
    5757 
     58      IF( l_1st_euler .OR. ln_top_euler ) THEN 
     59         tr(:,:,:,jp_age,Kbb) = tr(:,:,:,jp_age,Kmm) 
     60      ENDIF 
     61 
    5862 
    5963      DO jk = 1, nla_age 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/TOP/TRP/trcatf.F90

    r14086 r14200  
    2525   !!   'key_top'                                                TOP models 
    2626   !!---------------------------------------------------------------------- 
    27    !!   trc_atf     : time stepping on passive tracers 
     27   !!   trc_atf       : time stepping on passive tracers 
    2828   !!---------------------------------------------------------------------- 
    2929   USE par_trc        ! need jptra, number of passive tracers 
    30    USE oce_trc         ! ocean dynamics and tracers variables 
    31    USE trc             ! ocean passive tracers variables 
     30   USE oce_trc        ! ocean dynamics and tracers variables 
     31   USE trc            ! ocean passive tracers variables 
    3232   USE trd_oce 
    3333   USE trdtra 
    34 # if defined key_qco 
    35    USE traatf_qco 
     34# if defined key_qco   ||   defined key_linssh 
     35   USE traatf_qco     ! tracer : Asselin filter (qco) 
    3636# else 
    37    USE traatf 
     37   USE traatf         ! tracer : Asselin filter (vvl) 
    3838# endif 
    3939   USE bdy_oce   , ONLY: ln_bdy 
    40    USE trcbdy          ! BDY open boundaries 
     40   USE trcbdy         ! BDY open boundaries 
    4141# if defined key_agrif 
    4242   USE agrif_top_interp 
    4343# endif 
    4444   ! 
    45    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    46    USE prtctl          ! Print control for debbuging 
     45   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     46   USE prtctl         ! Print control for debbuging 
    4747 
    4848   IMPLICIT NONE 
    … …  
    103103#endif 
    104104      ! Update after tracer on domain lateral boundaries 
    105       CALL lbc_lnk( 'trcatf', ptr(:,:,:,:,Kaa), 'T', 1. )    
     105      CALL lbc_lnk( 'trcatf', ptr(:,:,:,:,Kaa), 'T', 1._wp )    
    106106 
    107107      IF( ln_bdy )  CALL trc_bdy( kt, Kbb, Kmm, Kaa ) 
    … …  
    157157      ELSE      
    158158         IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping 
    159 # if defined key_qco 
     159# if defined key_qco   ||   defined key_linssh 
    160160            IF( ln_linssh ) THEN   ;   CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nittrc000,        'TRC', ptr, jptra )                     !     linear ssh 
    161161            ELSE                   ;   CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 
    162162# else 
    163             IF( ln_linssh ) THEN   ;   CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000,         'TRC', ptr, jptra )                     !     linear ssh 
    164             ELSE                   ;   CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 
     163            IF( ln_linssh ) THEN   ;   CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000,         'TRC', ptr, jptra )                       !     linear ssh 
     164            ELSE                   ;   CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra )    ! non-linear ssh 
    165165# endif 
    166166            ENDIF 
    … …  
    169169         ENDIF 
    170170         ! 
    171          CALL lbc_lnk_multi( 'trcatf', ptr(:,:,:,:,Kmm), 'T', 1._wp, ptr(:,:,:,:,Kaa), 'T', 1._wp, ptr(:,:,:,:,Kaa), 'T', 1._wp ) 
     171         CALL lbc_lnk( 'trcatf', ptr(:,:,:,:,Kmm), 'T', 1._wp ) 
    172172      ENDIF 
    173173      ! 
    … …  
    193193   END SUBROUTINE trc_atf 
    194194 
    195 # if ! defined key_qco 
     195# if defined key_qco   ||   defined key_linssh 
    196196   SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 
    197197      !!---------------------------------------------------------------------- 
    … …  
    225225      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    226226      REAL(wp) ::   ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    227       REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d   !   -      - 
     227      REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f           !   -      - 
    228228      !!---------------------------------------------------------------------- 
    229229      ! 
    … …  
    241241      DO jn = 1, jptra       
    242242         DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    243             ze3t_b = e3t(ji,jj,jk,Kbb) 
    244             ze3t_n = e3t(ji,jj,jk,Kmm) 
    245             ze3t_a = e3t(ji,jj,jk,Kaa) 
     243            ze3t_b = 1._wp + r3t(ji,jj,Kbb) * tmask(ji,jj,jk) 
     244            ze3t_n = 1._wp + r3t(ji,jj,Kmm) * tmask(ji,jj,jk) 
     245            ze3t_a = 1._wp + r3t(ji,jj,Kaa) * tmask(ji,jj,jk) 
    246246            !                                         ! tracer content at Before, now and after 
    247             ztc_b  = ptr(ji,jj,jk,jn,Kbb)  * ze3t_b 
    248             ztc_n  = ptr(ji,jj,jk,jn,Kmm)  * ze3t_n 
     247            ztc_b  = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 
     248            ztc_n  = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 
    249249            ztc_a  = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 
    250250            ! 
    251             ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 
    252251            ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
    253252            ! 
    254             ze3t_f = ze3t_n + rn_atfp * ze3t_d 
     253            ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk) 
    255254            ztc_f  = ztc_n  + rn_atfp * ztc_d 
    256255            ! 
    257256            IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN           ! first level  
    258                ze3t_f = ze3t_f - rfact2 * ( emp_b(ji,jj)      - emp(ji,jj)   )  
    259257               ztc_f  = ztc_f  - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 
    260258            ENDIF 
    … …  
    300298      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    301299      REAL(wp) ::   ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    302       REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f           !   -      - 
     300      REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d   !   -      - 
    303301      !!---------------------------------------------------------------------- 
    304302      ! 
    … …  
    316314      DO jn = 1, jptra       
    317315         DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    318             ze3t_b = 1._wp + r3t(ji,jj,Kbb) * tmask(ji,jj,jk) 
    319             ze3t_n = 1._wp + r3t(ji,jj,Kmm) * tmask(ji,jj,jk) 
    320             ze3t_a = 1._wp + r3t(ji,jj,Kaa) * tmask(ji,jj,jk) 
     316            ze3t_b = e3t(ji,jj,jk,Kbb) 
     317            ze3t_n = e3t(ji,jj,jk,Kmm) 
     318            ze3t_a = e3t(ji,jj,jk,Kaa) 
    321319            !                                         ! tracer content at Before, now and after 
    322             ztc_b  = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 
    323             ztc_n  = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 
     320            ztc_b  = ptr(ji,jj,jk,jn,Kbb)  * ze3t_b 
     321            ztc_n  = ptr(ji,jj,jk,jn,Kmm)  * ze3t_n 
    324322            ztc_a  = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 
    325323            ! 
     324            ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 
    326325            ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
    327326            ! 
    328             ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk) 
     327            ze3t_f = ze3t_n + rn_atfp * ze3t_d 
    329328            ztc_f  = ztc_n  + rn_atfp * ztc_d 
    330329            ! 
    331330            IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN           ! first level  
     331               ze3t_f = ze3t_f - rfact2 * ( emp_b(ji,jj)      - emp(ji,jj)   )  
    332332               ztc_f  = ztc_f  - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 
    333333            ENDIF 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/TOP/trcais.F90

    r14032 r14200  
    3838   !! * Substitutions 
    3939#  include "do_loop_substitute.h90" 
     40#  include "domzgr_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/BENCH/cpp_BENCH.fcm

    r10343 r14200  
    1  bld::tool::fppkeys key_mpp_mpi key_si3 key_top 
     1 bld::tool::fppkeys key_mpp_mpi key_si3 key_top key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/C1D_ASICS/cpp_C1D_ASICS.fcm

    r14021 r14200  
    1  bld::tool::fppkeys   key_c1d key_mpp_mpi key_iomput 
     1 bld::tool::fppkeys   key_c1d key_qco key_mpp_mpi key_iomput 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/CANAL/MY_SRC/usrdef_istate.F90

    r14053 r14200  
    1616   USE dom_oce         
    1717   USE phycst         ! physical constants 
     18   USE eosbn2, ONLY: rn_a0 
    1819   ! 
    1920   USE in_out_manager ! I/O manager 
    … …  
    197198                  zrho1 = zrho1 - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
    198199               ENDIF 
    199                !               pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
    200                pts(ji,jj,jk,jp_tem) = (10._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
     200               !               pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / rn_a0) * ptmask(ji,jj,jk) 
     201               pts(ji,jj,jk,jp_tem) = (10._wp + (rho0-zrho1) / rn_a0) * ptmask(ji,jj,jk) 
    201202            END DO 
    202203         END_2D 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/CANAL/cpp_CANAL.fcm

    r10425 r14200  
    1  bld::tool::fppkeys key_iomput key_mpp_mpi  
     1 bld::tool::fppkeys key_iomput key_mpp_mpi key_qco  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/CPL_OASIS/cpp_CPL_OASIS.fcm

    r12663 r14200  
    1 bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi key_oasis3 
     1bld::tool::fppkeys   key_si3 key_top key_iomput key_mpp_mpi key_oasis3 key_qco 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/DOME/MY_SRC/usrdef_istate.F90

    r14001 r14200  
    1515   USE par_oce        ! ocean space and time domain 
    1616   USE phycst         ! physical constants 
     17   USE eosbn2, ONLY: rn_a0 
    1718   ! 
    1819   USE in_out_manager ! I/O manager 
    … …  
    2324 
    2425   PUBLIC   usr_def_istate   ! called by istate.F90 
    25  
     26   PUBlIC   usr_def_istate_ssh 
    2627   !!---------------------------------------------------------------------- 
    2728   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3435CONTAINS 
    3536   
    36    SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 
     37   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 
    3738      !!---------------------------------------------------------------------- 
    3839      !!                   ***  ROUTINE usr_def_istate  *** 
    … …  
    5455      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s]  
    5556      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s]  
    56       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height 
    5757      ! 
    5858      INTEGER  :: ji,jj,jk     ! dummy loop indices 
    … …  
    7070      pu  (:,:,:) = 0._wp        ! ocean at rest 
    7171      pv  (:,:,:) = 0._wp 
    72       pssh(:,:)   = 0._wp 
    7372      pts(:,:,:,:) = 0._wp 
    7473      ! 
    … …  
    10099               zf = 1._wp 
    101100            ENDIF    
    102             zrho1 = rho0*zn2*zdt/grav/0.2_wp 
     101            zrho1 = rho0*zn2*zdt/grav/rn_a0 
    103102            pts(ji,jj,jk,jp_tem) = (15._wp - zrho1) * ptmask(ji,jj,jk) 
    104103! Mass conserving initialization: 
    105 !            ztd = 15._wp*gdepw_0(ji,jj,jk+1)-0.5*rho0*zn2/(0.2_wp*grav)*gdepw_0(ji,jj,jk+1)**2 
    106 !            ztu = 15._wp*gdepw_0(ji,jj,jk  )-0.5*rho0*zn2/(0.2_wp*grav)*gdepw_0(ji,jj,jk  )**2 
    107 !            pts(ji,jj,jk,jp_tem) = (ztd - ztu)/e3t_0(ji,jj,jk) * ptmask(ji,jj,jk) 
     104            ztd = 15._wp*gdepw_0(ji,jj,jk+1)-0.5*rho0*zn2/(rn_a0*grav)*gdepw_0(ji,jj,jk+1)**2 
     105            ztu = 15._wp*gdepw_0(ji,jj,jk  )-0.5*rho0*zn2/(rn_a0*grav)*gdepw_0(ji,jj,jk  )**2 
     106            pts(ji,jj,jk,jp_tem) = (ztd - ztu)/e3t_0(ji,jj,jk) * ptmask(ji,jj,jk) 
    108107            IF (Agrif_root().AND.(  mjg0(jj) == Nj0glo-2 ) )  THEN 
    109108               pv(ji,jj,jk) = -sqrt(zdb*zh0)*exp(-zxw/zro)*(1._wp-zf) * ptmask(ji,jj,jk) 
    110109            ENDIF 
    111110            IF (Agrif_root().AND.(  mjg0(jj) == Nj0glo-1 ) )  THEN 
    112                pts(ji,jj,jk,jp_tem) = MIN(pts(ji,jj,jk,jp_tem), 15._wp - zdb*rho0/grav/0.2_wp*(1._wp-zf)) * ptmask(ji,jj,jk)  
     111               pts(ji,jj,jk,jp_tem) = MIN(pts(ji,jj,jk,jp_tem), 15._wp - zdb*rho0/grav/rn_a0*(1._wp-zf)) * ptmask(ji,jj,jk)  
    113112               pts(ji,jj,jk,jp_sal) = 1._wp * ptmask(ji,jj,jk)  
    114113            ENDIF 
    … …  
    118117   END SUBROUTINE usr_def_istate 
    119118 
     119   
     120   SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 
     121      !!---------------------------------------------------------------------- 
     122      !!                   ***  ROUTINE usr_def_istate  *** 
     123      !!  
     124      !! ** Purpose :   Initialization of ssh 
     125      !!                Here DOME configuration  
     126      !! 
     127      !! ** Method  :   set no initial sea level anomaly 
     128      !!   
     129      !!---------------------------------------------------------------------- 
     130      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! 
     131      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! 
     132      ! 
     133      !!---------------------------------------------------------------------- 
     134      ! 
     135      pssh(:,:) = 0._wp 
     136      ! 
     137   END SUBROUTINE usr_def_istate_ssh 
     138 
    120139   !!====================================================================== 
    121140END MODULE usrdef_istate 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/DOME/cpp_DOME.fcm

    r13930 r14200  
    1  bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif 
     1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif key_linssh 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICB/cpp_ICB.fcm

    r13899 r14200  
    1  bld::tool::fppkeys   key_iomput key_mpp_mpi  
     1 bld::tool::fppkeys   key_iomput key_mpp_mpi key_qco  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICE_ADV1D/cpp_ICE_ADV1D.fcm

    r10513 r14200  
    1 bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput 
     1bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput key_linssh 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICE_ADV2D/cpp_ICE_ADV2D.fcm

    r10515 r14200  
    1 bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput 
     1bld::tool::fppkeys key_si3 key_linssh key_mpp_mpi key_nosignedzero key_iomput 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm

    r10516 r14200  
    1 bld::tool::fppkeys key_agrif key_si3 key_mpp_mpi key_iomput 
     1bld::tool::fppkeys key_agrif key_si3 key_linssh key_mpp_mpi key_iomput 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90

    r14021 r14200  
    66   !! History :   -   !  2007-03  (M.A. Morales Maqueda, S. Bouillon) Original code 
    77   !!            3.0  !  2008-03  (M. Vancoppenolle) adaptation to new model 
    8    !!             -   !  2008-11  (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy  
     8   !!             -   !  2008-11  (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy 
    99   !!            3.3  !  2009-05  (G.Garric)    addition of the evp case 
    10    !!            3.4  !  2011-01  (A. Porter)   dynamical allocation  
     10   !!            3.4  !  2011-01  (A. Porter)   dynamical allocation 
    1111   !!            3.5  !  2012-08  (R. Benshila) AGRIF 
    1212   !!            3.6  !  2016-06  (C. Rousset)  Rewriting + landfast ice + mEVP (Bouillon 2013) 
    … …  
    1414   !!            4.0  !  2018     (many people) SI3 [aka Sea Ice cube] 
    1515   !!                 !  2019     (S. Rynders, Y. Aksenov, C. Rousset)  change into eap rheology from 
    16    !!                                           CICE code (Tsamados, Heorton)  
     16   !!                                           CICE code (Tsamados, Heorton) 
    1717   !!---------------------------------------------------------------------- 
    1818#if defined key_si3 
    … …  
    3030   USE icevar         ! ice_var_sshdyn 
    3131   USE icedyn_rdgrft  ! sea-ice: ice strength 
    32    USE bdy_oce , ONLY : ln_bdy  
    33    USE bdyice  
     32   USE bdy_oce , ONLY : ln_bdy 
     33   USE bdyice 
    3434#if defined key_agrif 
    3535   USE agrif_ice_interp 
    … …  
    6666   INTEGER ::   ncvgid   ! netcdf file id 
    6767   INTEGER ::   nvarid   ! netcdf variable id 
    68    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zmsk00, zmsk15 
     68   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   aimsk00 
     69   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   eap_res  , aimsk15 
    6970   !!---------------------------------------------------------------------- 
    7071   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    8081      !! 
    8182      !! ** purpose : determines sea ice drift from wind stress, ice-ocean 
    82       !!  stress and sea-surface slope. Ice-ice interaction is described by  
    83       !!  a non-linear elasto-anisotropic-plastic (EAP) law including shear  
    84       !!  strength and a bulk rheology .   
     83      !!  stress and sea-surface slope. Ice-ice interaction is described by 
     84      !!  a non-linear elasto-anisotropic-plastic (EAP) law including shear 
     85      !!  strength and a bulk rheology . 
    8586      !! 
    8687      !!  The points in the C-grid look like this, dear reader 
    … …  
    9091      !!                                 | 
    9192      !!                      (ji-1,jj)  |  (ji,jj) 
    92       !!                             ---------    
     93      !!                             --------- 
    9394      !!                            |         | 
    9495      !!                            | (ji,jj) |------(ji,jj) 
    9596      !!                            |         | 
    96       !!                             ---------    
     97      !!                             --------- 
    9798      !!                     (ji-1,jj-1)     (ji,jj-1) 
    9899      !! 
    … …  
    101102      !!                snow total volume (vt_s) per unit area 
    102103      !! 
    103       !! ** Action  : - compute u_ice, v_ice : the components of the  
     104      !! ** Action  : - compute u_ice, v_ice : the components of the 
    104105      !!                sea-ice velocity vector 
    105106      !!              - compute delta_i, shear_i, divu_i, which are inputs 
    … …  
    107108      !! 
    108109      !! ** Steps   : 0) compute mask at F point 
    109       !!              1) Compute ice snow mass, ice strength  
     110      !!              1) Compute ice snow mass, ice strength 
    110111      !!              2) Compute wind, oceanic stresses, mass terms and 
    111112      !!                 coriolis terms of the momentum equation 
    … …  
    166167      REAL(wp), DIMENSION(jpi,jpj) ::   zmU_t, zmV_t                    ! (ice-snow_mass / dt) on U/V points 
    167168      REAL(wp), DIMENSION(jpi,jpj) ::   zmf                             ! coriolis parameter at T points 
    168       REAL(wp), DIMENSION(jpi,jpj) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points                            
     169      REAL(wp), DIMENSION(jpi,jpj) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points 
    169170      ! 
    170171      REAL(wp), DIMENSION(jpi,jpj) ::   zds                             ! shear 
    … …  
    172173      REAL(wp), DIMENSION(jpi,jpj) ::   zsshdyn                         ! array used for the calculation of ice surface slope: 
    173174      !                                                                 !    ocean surface (ssh_m) if ice is not embedded 
    174       !                                                                 !    ice bottom surface if ice is embedded    
     175      !                                                                 !    ice bottom surface if ice is embedded 
    175176      REAL(wp), DIMENSION(jpi,jpj) ::   zfU  , zfV                      ! internal stresses 
    176177      REAL(wp), DIMENSION(jpi,jpj) ::   zspgU, zspgV                    ! surface pressure gradient at U/V points 
    … …  
    192193      !! --- diags 
    193194      REAL(wp) ::   zsig1, zsig2, zsig12, zfac, z1_strength 
    194       REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zsig_I, zsig_II, zsig1_p, zsig2_p          
     195      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zsig_I, zsig_II, zsig1_p, zsig2_p 
    195196      !! --- SIMIP diags 
    196197      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s) 
    … …  
    199200      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_ymtrp_snw ! Y-component of snow mass transport (kg/s) 
    200201      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xatrp     ! X-component of area transport (m2/s) 
    201       REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_yatrp     ! Y-component of area transport (m2/s)       
     202      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_yatrp     ! Y-component of area transport (m2/s) 
    202203      !!------------------------------------------------------------------- 
    203204 
    204205      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_rhg_eap: EAP sea-ice rheology' 
    205206      ! 
    206       ! for diagnostics and convergence tests 
    207       ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 
     207      IF( kt == nit000 )  THEN  
     208         ! 
     209         ! for diagnostics  
     210         ALLOCATE( aimsk00(jpi,jpj) ) 
     211         ! for convergence tests 
     212         IF( nn_rhg_chkcvg > 0 ) ALLOCATE( eap_res(jpi,jpj), aimsk15(jpi,jpj) ) 
     213      ENDIF 
     214      ! 
    208215      DO_2D( 1, 1, 1, 1 ) 
    209          zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    210          zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     216         aimsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    211217      END_2D 
     218      IF( nn_rhg_chkcvg > 0 ) THEN 
     219         DO_2D( 1, 1, 1, 1 ) 
     220            aimsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     221         END_2D 
     222      ENDIF 
    212223      ! 
    213224!!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization.... 
    … …  
    249260      ! 1) define some variables and initialize arrays 
    250261      !------------------------------------------------------------------------------! 
    251       zrhoco = rho0 * rn_cio  
     262      zrhoco = rho0 * rn_cio 
    252263!extra code for test case boundary conditions 
    253264      zinvw=1._wp/(zrhoco*0.5_wp) 
    … …  
    270281      ENDIF 
    271282      z1_dtevp = 1._wp / zdtevp 
    272           
    273       ! Initialise stress tensor  
    274       zs1 (:,:) = pstress1_i (:,:)  
     283 
     284      ! Initialise stress tensor 
     285      zs1 (:,:) = pstress1_i (:,:) 
    275286      zs2 (:,:) = pstress2_i (:,:) 
    276287      zs12(:,:) = pstress12_i(:,:) 
    … …  
    319330         ! dt/m at T points (for alpha and beta coefficients) 
    320331         zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin ) 
    321           
     332 
    322333         ! m/dt 
    323334         zmU_t(ji,jj)    = zmassU * z1_dtevp 
    324335         zmV_t(ji,jj)    = zmassV * z1_dtevp 
    325           
     336 
    326337         ! Drag ice-atm. 
    327338         ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
    … …  
    353364            zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    354365            ! ice-bottom stress at U points 
    355             zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) 
     366            zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 
    356367            ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
    357368            ! ice-bottom stress at V points 
    358             zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) 
     369            zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 
    359370            ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
    360371            ! ice_bottom stress at T points 
    361             zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) 
     372            zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) )    ! if grounded icebergs are read: ocean depth = 0 
    362373            tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    363374         END_2D 
    … …  
    377388      !                                               ! ==================== ! 
    378389      DO jter = 1 , nn_nevp                           !    loop over jter    ! 
    379          !                                            ! ==================== !         
     390         !                                            ! ==================== ! 
    380391         l_full_nf_update = jter == nn_nevp   ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1 
    381392         ! 
    … …  
    404415               &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
    405416               &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    406             
     417 
    407418            ! divergence at T points 
    408419            zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    … …  
    410421               &    ) * r1_e1e2t(ji,jj) 
    411422            zdiv2 = zdiv * zdiv 
    412              
     423 
    413424            ! tension at T points 
    414425            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    … …  
    418429 
    419430            ! delta at T points 
    420             zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
     431            zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 
    421432 
    422433         END_2D 
    423434         CALL lbc_lnk( 'icedyn_rhg_eap', zdelta, 'T', 1.0_wp ) 
    424                 
     435 
    425436         ! P/delta at T points 
    426437         DO_2D( 1, 1, 1, 1 ) 
    … …  
    430441         DO_2D( 0, 1, 0, 1 )   ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 
    431442 
    432              ! shear at T points  
     443             ! shear at T points 
    433444            zdsT = ( zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
    434445               &   + zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
    435446               &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    436              
     447 
    437448           ! divergence at T points (duplication to avoid communications) 
    438449            zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    439450               &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    440451               &    ) * r1_e1e2t(ji,jj) 
    441              
     452 
    442453            ! tension at T points (duplication to avoid communications) 
    443454            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    … …  
    459470               zyield22(ji,jj) = 0.5_wp * (zstressptmp - zstressmtmp) 
    460471               zyield12(ji,jj) = zstress12tmp(ji,jj) 
    461                prdg_conv(ji,jj) = -min( zalphar, 0._wp)     
     472               prdg_conv(ji,jj) = -min( zalphar, 0._wp) 
    462473            ENDIF 
    463474 
    … …  
    491502 
    492503         DO_2D( 1, 0, 1, 0 ) 
    493             ! stress12tmp at F points  
     504            ! stress12tmp at F points 
    494505            zstress12tmpF = ( zstress12tmp(ji,jj+1) * e1e2t(ji,jj+1) + zstress12tmp(ji+1,jj+1) * e1e2t(ji+1,jj+1)  & 
    495506               &            + zstress12tmp(ji,jj  ) * e1e2t(ji,jj  ) + zstress12tmp(ji+1,jj  ) * e1e2t(ji+1,jj  )  & 
    … …  
    504515               ! zalph2 = zalph2 - 1._wp 
    505516            ENDIF 
    506              
     517 
    507518            ! stress at F points (zkt/=0 if landfast) 
    508519            zs12(ji,jj) = ( zs12(ji,jj) * zalph1 + zstress12tmpF ) * z1_alph1 
    … …  
    570581                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    571582                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    572                      &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   &  
     583                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   & 
    573584                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    574585                     &                                    ) / ( zbetav + 1._wp )                                              & 
    … …  
    630641                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    631642                     &                                    ) / ( zbetau + 1._wp )                                              & 
    632                      &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     643                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    633644                     &           )   * zmsk00x(ji,jj) 
    634645               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    … …  
    637648                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
    638649                     &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
    639                      &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                  & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     650                     &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                  & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    640651                     &            )   * zmsk00x(ji,jj) 
    641652               ENDIF 
    … …  
    689700                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    690701                     &                                    ) / ( zbetau + 1._wp )                                              & 
    691                      &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     702                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    692703                     &           )   * zmsk00x(ji,jj) 
    693704               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    … …  
    744755                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   & 
    745756                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    746                      &                                    ) / ( zbetav + 1._wp )                                              &  
     757                     &                                    ) / ( zbetav + 1._wp )                                              & 
    747758                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    748759                     &           )   * zmsk00y(ji,jj) 
    … …  
    771782 
    772783         ! convergence test 
    773          IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 
     784         IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg_eap( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 
    774785         ! 
    775786         !                                                ! ==================== ! 
    … …  
    781792      ! 
    782793      !------------------------------------------------------------------------------! 
    783       ! 4) Recompute delta, shear and div (inputs for mechanical redistribution)  
     794      ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) 
    784795      !------------------------------------------------------------------------------! 
    785796      DO_2D( 1, 0, 1, 0 ) 
    … …  
    791802 
    792803      END_2D 
    793        
     804 
    794805      DO_2D( 0, 0, 0, 0 ) 
    795           
     806 
    796807         ! tension**2 at T points 
    797808         zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    … …  
    799810            &   ) * r1_e1e2t(ji,jj) 
    800811         zdt2 = zdt * zdt 
    801           
     812 
    802813         zten_i(ji,jj) = zdt 
    803814 
    … …  
    806817            &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
    807818            &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    808           
     819 
    809820         ! shear at T points 
    810821         pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
    … …  
    814825            &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    815826            &             ) * r1_e1e2t(ji,jj) 
    816           
     827 
    817828         ! delta at T points 
    818          zfac            = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta   
     829         zfac            = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta 
    819830         rswitch         = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0 
    820831         pdelta_i(ji,jj) = zfac + rn_creepl * rswitch ! delta+creepl 
    … …  
    824835         &                                    zten_i, 'T', 1.0_wp, zs1    , 'T', 1.0_wp, zs2     , 'T', 1.0_wp, & 
    825836         &                                      zs12, 'F', 1.0_wp ) 
    826        
     837 
    827838      ! --- Store the stress tensor for the next time step --- ! 
    828839      pstress1_i (:,:) = zs1 (:,:) 
    … …  
    841852            &                                  ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
    842853         ! 
    843          CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) 
    844          CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 ) 
    845          CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 ) 
    846          CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 ) 
    847          CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 ) 
    848          CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 ) 
    849       ENDIF 
    850         
     854         CALL iom_put( 'utau_oi' , ztaux_oi * aimsk00 ) 
     855         CALL iom_put( 'vtau_oi' , ztauy_oi * aimsk00 ) 
     856         CALL iom_put( 'utau_ai' , ztaux_ai * aimsk00 ) 
     857         CALL iom_put( 'vtau_ai' , ztauy_ai * aimsk00 ) 
     858         CALL iom_put( 'utau_bi' , ztaux_bi * aimsk00 ) 
     859         CALL iom_put( 'vtau_bi' , ztauy_bi * aimsk00 ) 
     860      ENDIF 
     861 
    851862      ! --- divergence, shear and strength --- ! 
    852       IF( iom_use('icediv') )   CALL iom_put( 'icediv' , pdivu_i  * zmsk00 )   ! divergence 
    853       IF( iom_use('iceshe') )   CALL iom_put( 'iceshe' , pshear_i * zmsk00 )   ! shear 
    854       IF( iom_use('icedlt') )   CALL iom_put( 'icedlt' , pdelta_i * zmsk00 )   ! delta 
    855       IF( iom_use('icestr') )   CALL iom_put( 'icestr' , strength * zmsk00 )   ! strength 
     863      IF( iom_use('icediv') )   CALL iom_put( 'icediv' , pdivu_i  * aimsk00 )   ! divergence 
     864      IF( iom_use('iceshe') )   CALL iom_put( 'iceshe' , pshear_i * aimsk00 )   ! shear 
     865      IF( iom_use('icedlt') )   CALL iom_put( 'icedlt' , pdelta_i * aimsk00 )   ! delta 
     866      IF( iom_use('icestr') )   CALL iom_put( 'icestr' , strength * aimsk00 )   ! strength 
    856867 
    857868      ! --- Stress tensor invariants (SIMIP diags) --- ! 
    … …  
    859870         ! 
    860871         ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) 
    861          !          
     872         ! 
    862873         DO_2D( 1, 1, 1, 1 ) 
    863           
     874 
    864875            ! Ice stresses 
    865876            ! sigma1, sigma2, sigma12 are some useful recombination of the stresses (Hunke and Dukowicz MWR 2002, Bouillon et al., OM2013) 
    866877            ! These are NOT stress tensor components, neither stress invariants, neither stress principal components 
    867878            ! I know, this can be confusing... 
    868             zfac             =   strength(ji,jj) / ( pdelta_i(ji,jj) + rn_creepl )  
     879            zfac             =   strength(ji,jj) / ( pdelta_i(ji,jj) + rn_creepl ) 
    869880            zsig1            =   zfac * ( pdivu_i(ji,jj) - pdelta_i(ji,jj) ) 
    870881            zsig2            =   zfac * z1_ecc2 * zten_i(ji,jj) 
    871882            zsig12           =   zfac * z1_ecc2 * pshear_i(ji,jj) 
    872              
     883 
    873884            ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008) 
    874885            zsig_I (ji,jj)   =   zsig1 * 0.5_wp                                           ! 1st stress invariant, aka average normal stress, aka negative pressure 
    875886            zsig_II(ji,jj)   =   SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) )  ! 2nd  ''       '', aka maximum shear stress 
    876              
     887 
    877888         END_2D 
    878889         ! 
    879890         ! Stress tensor invariants (normal and shear stress N/m) - SIMIP diags - definitions following Coon (1974) and Feltham (2008) 
    880          IF( iom_use('normstr') )   CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress 
    881          IF( iom_use('sheastr') )   CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress 
    882           
     891         IF( iom_use('normstr') )   CALL iom_put( 'normstr', zsig_I (:,:) * aimsk00(:,:) ) ! Normal stress 
     892         IF( iom_use('sheastr') )   CALL iom_put( 'sheastr', zsig_II(:,:) * aimsk00(:,:) ) ! Maximum shear stress 
     893 
    883894         DEALLOCATE ( zsig_I, zsig_II ) 
    884           
     895 
    885896      ENDIF 
    886897 
    … …  
    891902      IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN 
    892903         ! 
    893          ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) )          
    894          !          
     904         ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) 
     905         ! 
    895906         DO_2D( 1, 1, 1, 1 ) 
    896           
    897             ! Ice stresses computed with **viscosities** (delta, p/delta) at **previous** iterates  
     907 
     908            ! Ice stresses computed with **viscosities** (delta, p/delta) at **previous** iterates 
    898909            !                        and **deformations** at current iterates 
    899910            !                        following Lemieux & Dupont (2020) 
    … …  
    902913            zsig2            =   zfac * z1_ecc2 * zten_i(ji,jj) 
    903914            zsig12           =   zfac * z1_ecc2 * pshear_i(ji,jj) 
    904              
     915 
    905916            ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008), T-point 
    906917            zsig_I(ji,jj)    =   zsig1 * 0.5_wp                                           ! 1st stress invariant, aka average normal stress, aka negative pressure 
    907918            zsig_II(ji,jj)   =   SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) )  ! 2nd  ''       '', aka maximum shear stress 
    908     
     919 
    909920            ! Normalized  principal stresses (used to display the ellipse) 
    910921            z1_strength      =   1._wp / MAX( 1._wp, strength(ji,jj) ) 
    … …  
    913924         END_2D 
    914925         ! 
    915          CALL iom_put( 'sig1_pnorm' , zsig1_p )  
    916          CALL iom_put( 'sig2_pnorm' , zsig2_p )  
    917        
     926         CALL iom_put( 'sig1_pnorm' , zsig1_p ) 
     927         CALL iom_put( 'sig2_pnorm' , zsig2_p ) 
     928 
    918929         DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II ) 
    919           
     930 
    920931      ENDIF 
    921932 
    … …  
    925936         CALL lbc_lnk_multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 
    926937 
    927          CALL iom_put( 'yield11', zyield11 * zmsk00 ) 
    928          CALL iom_put( 'yield22', zyield22 * zmsk00 ) 
    929          CALL iom_put( 'yield12', zyield12 * zmsk00 ) 
     938         CALL iom_put( 'yield11', zyield11 * aimsk00 ) 
     939         CALL iom_put( 'yield22', zyield22 * aimsk00 ) 
     940         CALL iom_put( 'yield12', zyield12 * aimsk00 ) 
    930941      ENDIF 
    931942 
    932943      ! --- anisotropy tensor --- ! 
    933       IF( iom_use('aniso') ) THEN        
    934          CALL lbc_lnk( 'icedyn_rhg_eap', paniso_11, 'T', 1.0_wp )  
    935          CALL iom_put( 'aniso' , paniso_11 * zmsk00 ) 
    936       ENDIF 
    937        
     944      IF( iom_use('aniso') ) THEN 
     945         CALL lbc_lnk( 'icedyn_rhg_eap', paniso_11, 'T', 1.0_wp ) 
     946         CALL iom_put( 'aniso' , paniso_11 * aimsk00 ) 
     947      ENDIF 
     948 
    938949      ! --- SIMIP --- ! 
    939950      IF(  iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & 
    … …  
    944955            &                                    zfU, 'U', -1.0_wp,   zfV, 'V', -1.0_wp ) 
    945956 
    946          CALL iom_put( 'dssh_dx' , zspgU * zmsk00 )   ! Sea-surface tilt term in force balance (x) 
    947          CALL iom_put( 'dssh_dy' , zspgV * zmsk00 )   ! Sea-surface tilt term in force balance (y) 
    948          CALL iom_put( 'corstrx' , zCorU * zmsk00 )   ! Coriolis force term in force balance (x) 
    949          CALL iom_put( 'corstry' , zCorV * zmsk00 )   ! Coriolis force term in force balance (y) 
    950          CALL iom_put( 'intstrx' , zfU   * zmsk00 )   ! Internal force term in force balance (x) 
    951          CALL iom_put( 'intstry' , zfV   * zmsk00 )   ! Internal force term in force balance (y) 
     957         CALL iom_put( 'dssh_dx' , zspgU * aimsk00 )   ! Sea-surface tilt term in force balance (x) 
     958         CALL iom_put( 'dssh_dy' , zspgV * aimsk00 )   ! Sea-surface tilt term in force balance (y) 
     959         CALL iom_put( 'corstrx' , zCorU * aimsk00 )   ! Coriolis force term in force balance (x) 
     960         CALL iom_put( 'corstry' , zCorV * aimsk00 )   ! Coriolis force term in force balance (y) 
     961         CALL iom_put( 'intstrx' , zfU   * aimsk00 )   ! Internal force term in force balance (x) 
     962         CALL iom_put( 'intstry' , zfV   * aimsk00 )   ! Internal force term in force balance (y) 
    952963      ENDIF 
    953964 
    … …  
    960971         DO_2D( 0, 0, 0, 0 ) 
    961972            ! 2D ice mass, snow mass, area transport arrays (X, Y) 
    962             zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
    963             zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
     973            zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * aimsk00(ji,jj) 
     974            zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * aimsk00(ji,jj) 
    964975 
    965976            zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
    … …  
    979990 
    980991         CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice )   ! X-component of sea-ice mass transport (kg/s) 
    981          CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice )   ! Y-component of sea-ice mass transport  
     992         CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice )   ! Y-component of sea-ice mass transport 
    982993         CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw )   ! X-component of snow mass transport (kg/s) 
    983994         CALL iom_put( 'ymtrpsnw' , zdiag_ymtrp_snw )   ! Y-component of snow mass transport 
    … …  
    9951006            IF( ln_aEVP ) THEN   ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
    9961007               CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & 
    997                   &                           ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     1008                  &                           ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * aimsk15(:,:) ) 
    9981009            ELSE                 ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
    9991010               CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & 
    1000                   &                                             ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     1011                  &                                             ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * aimsk15(:,:) ) 
    10011012            ENDIF 
    10021013         ENDIF 
    1003       ENDIF       
    1004       ! 
    1005       DEALLOCATE( zmsk00, zmsk15 ) 
     1014      ENDIF 
    10061015      ! 
    10071016   END SUBROUTINE ice_dyn_rhg_eap 
    10081017 
    1009     
    1010    SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb ) 
     1018 
     1019   SUBROUTINE rhg_cvg_eap( kt, kiter, kitermax, pu, pv, pub, pvb ) 
    10111020      !!---------------------------------------------------------------------- 
    1012       !!                    ***  ROUTINE rhg_cvg  *** 
    1013       !!                      
     1021      !!                    ***  ROUTINE rhg_cvg_eap  *** 
     1022      !! 
    10141023      !! ** Purpose :   check convergence of oce rheology 
    10151024      !! 
    … …  
    10191028      !!                This routine is called every sub-iteration, so it is cpu expensive 
    10201029      !! 
    1021       !! ** Note    :   for the first sub-iteration, uice_cvg is set to 0 (too large otherwise)    
     1030      !! ** Note    :   for the first sub-iteration, uice_cvg is set to 0 (too large otherwise) 
    10221031      !!---------------------------------------------------------------------- 
    10231032      INTEGER ,                 INTENT(in) ::   kt, kiter, kitermax       ! ocean time-step index 
    … …  
    10261035      INTEGER           ::   it, idtime, istatus 
    10271036      INTEGER           ::   ji, jj          ! dummy loop indices 
    1028       REAL(wp)          ::   zresm           ! local real  
     1037      REAL(wp)          ::   zresm           ! local real 
    10291038      CHARACTER(len=20) ::   clname 
    1030       REAL(wp), DIMENSION(jpi,jpj) ::   zres           ! check convergence 
    10311039      !!---------------------------------------------------------------------- 
    10321040 
    … …  
    10361044         IF( lwp ) THEN 
    10371045            WRITE(numout,*) 
    1038             WRITE(numout,*) 'rhg_cvg : ice rheology convergence control' 
     1046            WRITE(numout,*) 'rhg_cvg_eap : ice rheology convergence control' 
    10391047            WRITE(numout,*) '~~~~~~~' 
    10401048         ENDIF 
    … …  
    10531061      ! time 
    10541062      it = ( kt - 1 ) * kitermax + kiter 
    1055        
     1063 
    10561064      ! convergence 
    10571065      IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large) 
    … …  
    10591067      ELSE 
    10601068         DO_2D( 1, 1, 1, 1 ) 
    1061             zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
    1062                &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 
     1069            eap_res(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
     1070               &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * aimsk15(ji,jj) 
     1071            ! cut of the boundary of the box (forced velocities) 
     1072            IF (mjg(jj)<=30 .or. mjg(jj)>970 .or. mig(ji)<=30 .or. mig(ji)>970) THEN 
     1073               eap_res(ji,jj) = 0._wp 
     1074            END IF 
    10631075         END_2D 
    10641076 
    1065          ! cut of the boundary of the box (forced velocities) 
    1066          IF (mjg(jj)<=30 .or. mjg(jj)>970 .or. mig(ji)<=30 .or. mig(ji)>970) THEN 
    1067             zres(ji,jj) = 0._wp 
    1068          END IF 
    1069          zresm = MAXVAL( zres ) 
     1077         zresm = MAXVAL( eap_res ) 
    10701078         CALL mpp_max( 'icedyn_rhg_evp', zresm )   ! max over the global domain 
    10711079      ENDIF 
    … …  
    10771085         IF( kt == nitend )   istatus = NF90_CLOSE(ncvgid) 
    10781086      ENDIF 
    1079        
    1080    END SUBROUTINE rhg_cvg 
     1087 
     1088   END SUBROUTINE rhg_cvg_eap 
    10811089 
    10821090 
    … …  
    10851093      !!--------------------------------------------------------------------- 
    10861094      !!                   ***  SUBROUTINE update_stress_rdg  *** 
    1087       !!                      
     1095      !! 
    10881096      !! ** Purpose :   Updates the stress depending on values of strain rate and structure 
    10891097      !!                tensor and for the last subcycle step it computes closing and sliding rate 
    … …  
    10981106      INTEGER  ::   kx ,ky, ka 
    10991107 
    1100       REAL(wp) ::   zstemp11r, zstemp12r, zstemp22r    
    1101       REAL(wp) ::   zstemp11s, zstemp12s, zstemp22s  
    1102       REAL(wp) ::   za22, zQd11Qd11, zQd11Qd12, zQd12Qd12  
    1103       REAL(wp) ::   zQ11Q11, zQ11Q12, zQ12Q12  
    1104       REAL(wp) ::   zdtemp11, zdtemp12, zdtemp22  
    1105       REAL(wp) ::   zrotstemp11r, zrotstemp12r, zrotstemp22r    
     1108      REAL(wp) ::   zstemp11r, zstemp12r, zstemp22r 
     1109      REAL(wp) ::   zstemp11s, zstemp12s, zstemp22s 
     1110      REAL(wp) ::   za22, zQd11Qd11, zQd11Qd12, zQd12Qd12 
     1111      REAL(wp) ::   zQ11Q11, zQ11Q12, zQ12Q12 
     1112      REAL(wp) ::   zdtemp11, zdtemp12, zdtemp22 
     1113      REAL(wp) ::   zrotstemp11r, zrotstemp12r, zrotstemp22r 
    11061114      REAL(wp) ::   zrotstemp11s, zrotstemp12s, zrotstemp22s 
    1107       REAL(wp) ::   zsig11, zsig12, zsig22  
    1108       REAL(wp) ::   zsgprm11, zsgprm12, zsgprm22  
    1109       REAL(wp) ::   zinvstressconviso  
    1110       REAL(wp) ::   zAngle_denom_gamma,  zAngle_denom_alpha  
    1111       REAL(wp) ::   zTany_1, zTany_2  
    1112       REAL(wp) ::   zx, zy, zdx, zdy, zda, zkxw, kyw, kaw 
    1113       REAL(wp) ::   zinvdx, zinvdy, zinvda    
    1114       REAL(wp) ::   zdtemp1, zdtemp2, zatempprime, zinvsin 
    1115  
    1116       REAL(wp), PARAMETER ::   kfriction = 0.45_wp 
    1117       !!--------------------------------------------------------------------- 
     1115      REAL(wp) ::   zsig11, zsig12, zsig22 
     1116      REAL(wp) ::   zsgprm11, zsgprm12, zsgprm22 
     1117      REAL(wp) ::   zAngle_denom_gamma,  zAngle_denom_alpha 
     1118      REAL(wp) ::   zTany_1, zTany_2 
     1119      REAL(wp) ::   zx, zy, zkxw, kyw, kaw 
     1120      REAL(wp) ::   zinvdx, zinvdy, zinvda 
     1121      REAL(wp) ::   zdtemp1, zdtemp2, zatempprime 
     1122 
     1123      REAL(wp), PARAMETER ::   ppkfriction = 0.45_wp 
    11181124      ! Factor to maintain the same stress as in EVP (see Section 3) 
    11191125      ! Can be set to 1 otherwise 
    1120 !      zinvstressconviso = 1._wp/(1._wp+kfriction*kfriction) 
    1121       zinvstressconviso = 1._wp 
    1122   
    1123       zinvsin = 1._wp/sin(2._wp*pphi) * zinvstressconviso  
    1124       !now uses phi as set in higher code 
    1125         
     1126!     REAL(wp), PARAMETER ::   ppinvstressconviso = 1._wp/(1._wp+ppkfriction*ppkfriction) 
     1127      REAL(wp), PARAMETER ::   ppinvstressconviso = 1._wp 
     1128 
     1129      ! next statement uses pphi set in main module (icedyn_rhg_eap) 
     1130      REAL(wp), PARAMETER ::   ppinvsin = 1._wp/sin(2._wp*pphi) * ppinvstressconviso 
     1131 
    11261132      ! compute eigenvalues, eigenvectors and angles for structure tensor, strain 
    11271133      ! rates 
    … …  
    11321138      zQ12Q12 = rsmall 
    11331139      zQ11Q12 = rsmall 
    1134   
    1135       ! gamma: angle between general coordiantes and principal axis of A  
    1136       ! here Tan2gamma = 2 a12 / (a11 - a22)  
    1137       IF((ABS(pa11 - za22) > rsmall).OR.(ABS(pa12) > rsmall)) THEN       
     1140 
     1141      ! gamma: angle between general coordiantes and principal axis of A 
     1142      ! here Tan2gamma = 2 a12 / (a11 - a22) 
     1143      IF((ABS(pa11 - za22) > rsmall).OR.(ABS(pa12) > rsmall)) THEN 
    11381144         zAngle_denom_gamma = 1._wp/sqrt( ( pa11 - za22 )*( pa11 - za22) + & 
    11391145                              4._wp*pa12*pa12 ) 
    1140     
    1141          zQ11Q11 = 0.5_wp + ( pa11 - za22 )*0.5_wp*zAngle_denom_gamma   !Cos^2  
     1146 
     1147         zQ11Q11 = 0.5_wp + ( pa11 - za22 )*0.5_wp*zAngle_denom_gamma   !Cos^2 
    11421148         zQ12Q12 = 0.5_wp - ( pa11 - za22 )*0.5_wp*zAngle_denom_gamma   !Sin^2 
    1143          zQ11Q12 = pa12*zAngle_denom_gamma                     !CosSin  
    1144       ENDIF 
    1145   
     1149         zQ11Q12 = pa12*zAngle_denom_gamma                     !CosSin 
     1150      ENDIF 
     1151 
    11461152      ! rotation Q*atemp*Q^T 
    1147       zatempprime = zQ11Q11*pa11 + 2.0_wp*zQ11Q12*pa12 + zQ12Q12*za22  
    1148        
     1153      zatempprime = zQ11Q11*pa11 + 2.0_wp*zQ11Q12*pa12 + zQ12Q12*za22 
     1154 
    11491155      ! make first principal value the largest 
    11501156      zatempprime = max(zatempprime, 1.0_wp - zatempprime) 
    1151   
     1157 
    11521158      ! 2) strain rate 
    11531159      zdtemp11 = 0.5_wp*(pdivu + ptension) 
    … …  
    11551161      zdtemp22 = 0.5_wp*(pdivu - ptension) 
    11561162 
    1157       ! here Tan2alpha = 2 dtemp12 / (dtemp11 - dtemp22)  
     1163      ! here Tan2alpha = 2 dtemp12 / (dtemp11 - dtemp22) 
    11581164 
    11591165      zQd11Qd11 = 1.0_wp 
    … …  
    11661172                             ( zdtemp11 - zdtemp22 ) + 4.0_wp*zdtemp12*zdtemp12) 
    11671173 
    1168          zQd11Qd11 = 0.5_wp + ( zdtemp11 - zdtemp22 )*0.5_wp*zAngle_denom_alpha !Cos^2  
     1174         zQd11Qd11 = 0.5_wp + ( zdtemp11 - zdtemp22 )*0.5_wp*zAngle_denom_alpha !Cos^2 
    11691175         zQd12Qd12 = 0.5_wp - ( zdtemp11 - zdtemp22 )*0.5_wp*zAngle_denom_alpha !Sin^2 
    11701176         zQd11Qd12 = zdtemp12*zAngle_denom_alpha !CosSin 
    … …  
    11771183      IF ((ABS(zdtemp1) > rsmall).OR.(ABS(zdtemp2) > rsmall)) THEN 
    11781184         zx = atan2(zdtemp2,zdtemp1) 
    1179       ENDIF       
    1180                 
    1181       ! to ensure the angle lies between pi/4 and 9 pi/4  
     1185      ENDIF 
     1186 
     1187      ! to ensure the angle lies between pi/4 and 9 pi/4 
    11821188      IF (zx < rpi*0.25_wp) zx = zx + rpi*2.0_wp 
    1183        
     1189 
    11841190      ! y: angle between major principal axis of strain rate and structure 
    11851191      ! tensor 
    1186       ! y = gamma - alpha  
     1192      ! y = gamma - alpha 
    11871193      ! Expressesed componently with 
    11881194      ! Tany = (Singamma*Cosgamma - Sinalpha*Cosgamma)/(Cos^2gamma - Sin^alpha) 
    1189        
     1195 
    11901196      zTany_1 = zQ11Q12 - zQd11Qd12 
    11911197      zTany_2 = zQ11Q11 - zQd12Qd12 
    1192        
     1198 
    11931199      zy = 0._wp 
    1194        
     1200 
    11951201      IF ((ABS(zTany_1) > rsmall).OR.(ABS(zTany_2) > rsmall)) THEN 
    11961202         zy = atan2(zTany_1,zTany_2) 
    11971203      ENDIF 
    1198        
     1204 
    11991205      ! to make sure y is between 0 and pi 
    12001206      IF (zy > rpi) zy = zy - rpi 
    12011207      IF (zy < 0)  zy = zy + rpi 
    12021208 
    1203       ! 3) update anisotropic stress tensor  
    1204       zdx   = rpi/real(nx_yield-1,kind=wp) 
    1205       zdy   = rpi/real(ny_yield-1,kind=wp) 
    1206       zda   = 0.5_wp/real(na_yield-1,kind=wp) 
    1207       zinvdx = 1._wp/zdx 
    1208       zinvdy = 1._wp/zdy 
    1209       zinvda = 1._wp/zda 
     1209      ! 3) update anisotropic stress tensor 
     1210      zinvdx = real(nx_yield-1,kind=wp)/rpi 
     1211      zinvdy = real(ny_yield-1,kind=wp)/rpi 
     1212      zinvda = 2._wp*real(na_yield-1,kind=wp) 
    12101213 
    12111214      ! % need 8 coords and 8 weights 
    … …  
    12131216      kx  = int((zx-rpi*0.25_wp-rpi)*zinvdx) + 1 
    12141217      !!clem kx  = MAX( 1, MIN( nx_yield-1, INT((zx-rpi*0.25_wp-rpi)*zinvdx) + 1  ) ) 
    1215       zkxw = kx - (zx-rpi*0.25_wp-rpi)*zinvdx   
    1216        
     1218      zkxw = kx - (zx-rpi*0.25_wp-rpi)*zinvdx 
     1219 
    12171220      ky  = int(zy*zinvdy) + 1 
    12181221      !!clem ky  = MAX( 1, MIN( ny_yield-1, INT(zy*zinvdy) + 1 ) ) 
    1219       kyw = ky - zy*zinvdy  
    1220        
     1222      kyw = ky - zy*zinvdy 
     1223 
    12211224      ka  = int((zatempprime-0.5_wp)*zinvda) + 1 
    12221225      !!clem ka  = MAX( 1, MIN( na_yield-1, INT((zatempprime-0.5_wp)*zinvda) + 1 ) ) 
    12231226      kaw = ka - (zatempprime-0.5_wp)*zinvda 
    1224        
     1227 
    12251228      ! % Determine sigma_r(A1,Zeta,y) and sigma_s (see Section A1 of Tsamados 2013) 
    12261229!!$      zstemp11r =  zkxw  * kyw         * kaw         * s11r(kx  ,ky  ,ka  ) & 
    … …  
    12481251!!$        & + zkxw         * (1._wp-kyw) * (1._wp-kaw) * s22r(kx  ,ky+1,ka+1) & 
    12491252!!$        & + (1._wp-zkxw) * (1._wp-kyw) * (1._wp-kaw) * s22r(kx+1,ky+1,ka+1) 
    1250 !!$       
     1253!!$ 
    12511254!!$      zstemp11s =  zkxw  * kyw         * kaw         * s11s(kx  ,ky  ,ka  ) & 
    12521255!!$        & + (1._wp-zkxw) * kyw         * kaw         * s11s(kx+1,ky  ,ka  ) & 
    … …  
    12801283      zstemp12s = s12s(kx,ky,ka) 
    12811284      zstemp22s = s22s(kx,ky,ka) 
    1282        
    1283        
     1285 
     1286 
    12841287      ! Calculate mean ice stress over a collection of floes (Equation 3 in 
    12851288      ! Tsamados 2013) 
    12861289 
    1287       zsig11  = pstrength*(zstemp11r + kfriction*zstemp11s) * zinvsin 
    1288       zsig12  = pstrength*(zstemp12r + kfriction*zstemp12s) * zinvsin 
    1289       zsig22  = pstrength*(zstemp22r + kfriction*zstemp22s) * zinvsin 
     1290      zsig11  = pstrength*(zstemp11r + ppkfriction*zstemp11s) * ppinvsin 
     1291      zsig12  = pstrength*(zstemp12r + ppkfriction*zstemp12s) * ppinvsin 
     1292      zsig22  = pstrength*(zstemp22r + ppkfriction*zstemp22s) * ppinvsin 
    12901293 
    12911294      ! Back - rotation of the stress from principal axes into general coordinates 
    … …  
    13001303      pstressm  = zsgprm11 - zsgprm22 
    13011304 
    1302       ! Compute ridging and sliding functions in general coordinates  
     1305      ! Compute ridging and sliding functions in general coordinates 
    13031306      ! (Equation 11 in Tsamados 2013) 
    13041307      IF (ksub == kndte) THEN 
    … …  
    13071310         zrotstemp12r = zQ11Q11*zstemp12r +       zQ11Q12*(zstemp11r-zstemp22r) & 
    13081311                      - zQ12Q12*zstemp12r 
    1309          zrotstemp22r = zQ12Q12*zstemp11r + 2._wp*zQ11Q12* zstemp12r &  
     1312         zrotstemp22r = zQ12Q12*zstemp11r + 2._wp*zQ11Q12* zstemp12r & 
    13101313                      + zQ11Q11*zstemp22r 
    13111314 
    … …  
    13141317         zrotstemp12s = zQ11Q11*zstemp12s +       zQ11Q12*(zstemp11s-zstemp22s) & 
    13151318                      - zQ12Q12*zstemp12s 
    1316          zrotstemp22s = zQ12Q12*zstemp11s + 2._wp*zQ11Q12* zstemp12s &  
     1319         zrotstemp22s = zQ12Q12*zstemp11s + 2._wp*zQ11Q12* zstemp12s & 
    13171320                      + zQ11Q11*zstemp22s 
    13181321 
    … …  
    13221325                  + zrotstemp22s*zdtemp22 
    13231326      ENDIF 
    1324    END SUBROUTINE update_stress_rdg  
     1327   END SUBROUTINE update_stress_rdg 
    13251328 
    13261329!======================================================================= 
    … …  
    13311334      !!--------------------------------------------------------------------- 
    13321335      !!                   ***  ROUTINE calc_ffrac  *** 
    1333       !!                      
     1336      !! 
    13341337      !! ** Purpose :   Computes term in evolution equation for structure tensor 
    13351338      !!                which determines the ice floe re-orientation due to fracture 
    … …  
    13461349      REAL (wp) ::   zQ11, zQ12, zQ11Q11, zQ11Q12, zQ12Q12 
    13471350 
    1348 !!$      REAL (wp), PARAMETER ::   kfrac = 0.0001_wp   ! rate of fracture formation  
    1349       REAL (wp), PARAMETER ::   kfrac = 1.e-3_wp   ! rate of fracture formation  
    1350       REAL (wp), PARAMETER ::   threshold = 0.3_wp  ! critical confinement ratio  
     1351!!$   REAL (wp), PARAMETER ::   ppkfrac = 0.0001_wp   ! rate of fracture formation 
     1352      REAL (wp), PARAMETER ::   ppkfrac = 1.e-3_wp    ! rate of fracture formation 
     1353      REAL (wp), PARAMETER ::   ppthreshold = 0.3_wp  ! critical confinement ratio 
    13511354      !!--------------------------------------------------------------- 
    13521355      ! 
    1353       zsigma11 = 0.5_wp*(pstressp+pstressm)  
    1354       zsigma12 = pstress12  
    1355       zsigma22 = 0.5_wp*(pstressp-pstressm)  
     1356      zsigma11 = 0.5_wp*(pstressp+pstressm) 
     1357      zsigma12 = pstress12 
     1358      zsigma22 = 0.5_wp*(pstressp-pstressm) 
    13561359 
    13571360      ! Here's the change - no longer calculate gamma, 
    13581361      ! use trig formulation, angle signs are kept correct, don't worry 
    1359     
     1362 
    13601363      ! rotate tensor to get into sigma principal axis 
    1361     
    1362       ! here Tan2gamma = 2 sig12 / (sig11 - sig12)  
    1363       ! add rsmall to the denominator to stop 1/0 errors, makes very little  
     1364 
     1365      ! here Tan2gamma = 2 sig12 / (sig11 - sig12) 
     1366      ! add rsmall to the denominator to stop 1/0 errors, makes very little 
    13641367      ! error to the calculated angles < rsmall 
    13651368 
    … …  
    13731376                       zsigma22 ) + 4.0_wp*zsigma12*zsigma12) 
    13741377 
    1375          zQ11Q11 = 0.5_wp + ( zsigma11 - zsigma22 )*0.5_wp*zAngle_denom   !Cos^2  
     1378         zQ11Q11 = 0.5_wp + ( zsigma11 - zsigma22 )*0.5_wp*zAngle_denom   !Cos^2 
    13761379         zQ12Q12 = 0.5_wp - ( zsigma11 - zsigma22 )*0.5_wp*zAngle_denom   !Sin^2 
    1377          zQ11Q12 = zsigma12*zAngle_denom                      !CosSin  
     1380         zQ11Q12 = zsigma12*zAngle_denom                      !CosSin 
    13781381      ENDIF 
    13791382 
    … …  
    13901393      ! which leads to the loss of their shape, so we again model it through diffusion 
    13911394      ELSEIF ((zsigma_1 >= 0.0_wp).AND.(zsigma_2 < 0.0_wp))  THEN 
    1392          pmresult11 = - kfrac * (pa11 - zQ12Q12) 
    1393          pmresult12 = - kfrac * (pa12 + zQ11Q12) 
     1395         pmresult11 = - ppkfrac * (pa11 - zQ12Q12) 
     1396         pmresult12 = - ppkfrac * (pa12 + zQ11Q12) 
    13941397 
    13951398      ! Shear faulting 
    … …  
    13971400         pmresult11 = 0.0_wp 
    13981401         pmresult12 = 0.0_wp 
    1399       ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= threshold)) THEN 
    1400          pmresult11 = - kfrac * (pa11 - zQ12Q12) 
    1401          pmresult12 = - kfrac * (pa12 + zQ11Q12) 
     1402      ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= ppthreshold)) THEN 
     1403         pmresult11 = - ppkfrac * (pa11 - zQ12Q12) 
     1404         pmresult12 = - ppkfrac * (pa12 + zQ11Q12) 
    14021405 
    14031406      ! Horizontal spalling 
    1404       ELSE  
     1407      ELSE 
    14051408         pmresult11 = 0.0_wp 
    14061409         pmresult12 = 0.0_wp 
    … …  
    14131416      !!--------------------------------------------------------------------- 
    14141417      !!                   ***  ROUTINE rhg_eap_rst  *** 
    1415       !!                      
     1418      !! 
    14161419      !! ** Purpose :   Read or write RHG file in restart file 
    1417       !!       
     1420      !! 
    14181421      !! ** Method  :   use of IOM library 
    14191422      !!---------------------------------------------------------------------- 
    … …  
    14241427      INTEGER  ::   id1, id2, id3, id4, id5   ! local integers 
    14251428      INTEGER  ::   ix, iy, ip, iz, n, ia     ! local integers 
    1426      
     1429 
    14271430      INTEGER, PARAMETER            ::    nz = 100 
    1428        
     1431 
    14291432      REAL(wp) ::   ainit, xinit, yinit, pinit, zinit 
    14301433      REAL(wp) ::   da, dx, dy, dp, dz, a1 
    … …  
    14321435      !!clem 
    14331436      REAL(wp) ::   zw1, zw2, zfac, ztemp 
    1434       REAL(wp) ::   idx, idy, idz 
     1437      REAL(wp) ::   zidx, zidy, zidz 
     1438      REAL(wp) ::   zsaak(6)                  ! temporary array 
    14351439 
    14361440      REAL(wp), PARAMETER           ::   eps6 = 1.0e-6_wp 
    … …  
    15081512!!$                        s22r(ix,iy,ia) = s22r(ix,iy,ia) + 1*w1(ainit+ia*da)* & 
    15091513!!$                           exp(-w2(ainit+ia*da)*(zinit+iz*dz)*(zinit+iz*dz))* & 
    1510 !!$                           s22kr(xinit+ix*dx,yinit+iy*dy,zinit+iz*dz)*dz/sin(2._wp*pphi)  
     1514!!$                           s22kr(xinit+ix*dx,yinit+iy*dy,zinit+iz*dz)*dz/sin(2._wp*pphi) 
    15111515!!$                        s11s(ix,iy,ia) = s11s(ix,iy,ia) + 1*w1(ainit+ia*da)* & 
    15121516!!$                           exp(-w2(ainit+ia*da)*(zinit+iz*dz)*(zinit+iz*dz))* & 
    … …  
    15431547!!$         ENDDO 
    15441548 
    1545          !! faster but still very slow => to be improved          
     1549         !! faster but still very slow => to be improved 
    15461550         zfac = dz/sin(2._wp*pphi) 
    15471551         DO ia = 1, na_yield-1 
    … …  
    15491553            zw2 = w2(ainit+ia*da) 
    15501554            DO iz = 1, nz 
    1551                idz = zinit+iz*dz 
     1555               zidz = zinit+iz*dz 
    15521556               ztemp = zw1 * EXP(-zw2*(zinit+iz*dz)*(zinit+iz*dz)) 
    15531557               DO iy = 1, ny_yield 
    1554                   idy = yinit+iy*dy 
     1558                  zidy = yinit+iy*dy 
    15551559                  DO ix = 1, nx_yield 
    1556                      idx = xinit+ix*dx 
    1557                      s11r(ix,iy,ia) = s11r(ix,iy,ia) + ztemp * s11kr(idx,idy,idz)*zfac 
    1558                      s12r(ix,iy,ia) = s12r(ix,iy,ia) + ztemp * s12kr(idx,idy,idz)*zfac 
    1559                      s22r(ix,iy,ia) = s22r(ix,iy,ia) + ztemp * s22kr(idx,idy,idz)*zfac  
    1560                      s11s(ix,iy,ia) = s11s(ix,iy,ia) + ztemp * s11ks(idx,idy,idz)*zfac 
    1561                      s12s(ix,iy,ia) = s12s(ix,iy,ia) + ztemp * s12ks(idx,idy,idz)*zfac 
    1562                      s22s(ix,iy,ia) = s22s(ix,iy,ia) + ztemp * s22ks(idx,idy,idz)*zfac 
     1560                     zidx = xinit+ix*dx 
     1561                     call all_skr_sks(zidx,zidy,zidz,zsaak) 
     1562                     zsaak = ztemp*zsaak*zfac 
     1563                     s11r(ix,iy,ia) = s11r(ix,iy,ia) + zsaak(1) 
     1564                     s12r(ix,iy,ia) = s12r(ix,iy,ia) + zsaak(2) 
     1565                     s22r(ix,iy,ia) = s22r(ix,iy,ia) + zsaak(3) 
     1566                     s11s(ix,iy,ia) = s11s(ix,iy,ia) + zsaak(4) 
     1567                     s12s(ix,iy,ia) = s12s(ix,iy,ia) + zsaak(5) 
     1568                     s22s(ix,iy,ia) = s22s(ix,iy,ia) + zsaak(6) 
    15631569                  END DO 
    15641570               END DO 
    15651571            END DO 
    15661572         END DO 
    1567  
    15681573         zfac = 1._wp/sin(2._wp*pphi) 
    15691574         ia = na_yield 
    15701575         DO iy = 1, ny_yield 
    1571             idy = yinit+iy*dy 
     1576            zidy = yinit+iy*dy 
    15721577            DO ix = 1, nx_yield 
    1573                idx = xinit+ix*dx                   
    1574                s11r(ix,iy,ia) = 0.5_wp*s11kr(idx,idy,0._wp)*zfac 
    1575                s12r(ix,iy,ia) = 0.5_wp*s12kr(idx,idy,0._wp)*zfac 
    1576                s22r(ix,iy,ia) = 0.5_wp*s22kr(idx,idy,0._wp)*zfac 
    1577                s11s(ix,iy,ia) = 0.5_wp*s11ks(idx,idy,0._wp)*zfac 
    1578                s12s(ix,iy,ia) = 0.5_wp*s12ks(idx,idy,0._wp)*zfac 
    1579                s22s(ix,iy,ia) = 0.5_wp*s22ks(idx,idy,0._wp)*zfac 
     1578               zidx = xinit+ix*dx 
     1579               call all_skr_sks(zidx,zidy,0._wp,zsaak) 
     1580               zsaak = 0.5_wp*zsaak*zfac 
     1581               s11r(ix,iy,ia) = zsaak(1) 
     1582               s12r(ix,iy,ia) = zsaak(2) 
     1583               s22r(ix,iy,ia) = zsaak(3) 
     1584               s11s(ix,iy,ia) = zsaak(4) 
     1585               s12s(ix,iy,ia) = zsaak(5) 
     1586               s22s(ix,iy,ia) = zsaak(6) 
    15801587            ENDDO 
    15811588         ENDDO 
    … …  
    16111618      REAL(wp) ::   w1 
    16121619      !!------------------------------------------------------------------- 
    1613     
     1620 
    16141621      w1 = -   223.87569446_wp & 
    16151622       &   +  2361.21986630_wp*pa & 
    … …  
    16201627       &   - 16789.98003081_wp*pa*pa*pa*pa*pa*pa & 
    16211628       &   +  3495.82839237_wp*pa*pa*pa*pa*pa*pa*pa 
    1622     
     1629 
    16231630   END FUNCTION w1 
    16241631 
    … …  
    16311638      REAL(wp) ::   w2 
    16321639      !!------------------------------------------------------------------- 
    1633     
     1640 
    16341641      w2 = -    6670.68911883_wp & 
    16351642       &   +   70222.33061536_wp*pa & 
    … …  
    16401647       &   -  493379.44906738_wp*pa*pa*pa*pa*pa*pa & 
    16411648       &   +  102356.55151800_wp*pa*pa*pa*pa*pa*pa*pa 
    1642     
     1649 
    16431650   END FUNCTION w2 
    16441651 
    1645    FUNCTION s11kr(px,py,pz)  
    1646       !!------------------------------------------------------------------- 
    1647       !! Function : s11kr 
    1648       !!------------------------------------------------------------------- 
     1652   SUBROUTINE all_skr_sks( px, py, pz, allsk ) 
    16491653      REAL(wp), INTENT(in   ) ::   px,py,pz 
    1650     
    1651       REAL(wp) ::   s11kr, zpih 
    1652     
     1654      REAL(wp), INTENT(out  ) ::   allsk(6) 
     1655 
     1656      REAL(wp) ::   zs12r0, zs21r0 
     1657      REAL(wp) ::   zs12s0, zs21s0 
     1658 
     1659      REAL(wp) ::   zpih 
    16531660      REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    16541661      REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    … …  
    16591666      REAL(wp) ::   zHen1t2, zHen2t1 
    16601667      !!------------------------------------------------------------------- 
    1661     
     1668 
    16621669      zpih = 0.5_wp*rpi 
    1663     
     1670 
    16641671      zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    16651672      zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    … …  
    16871694      zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    16881695      zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1689     
     1696 
    16901697      IF (-zIIn1t2>=rsmall) THEN 
    16911698      zHen1t2 = 1._wp 
    … …  
    16931700      zHen1t2 = 0._wp 
    16941701      ENDIF 
    1695     
     1702 
    16961703      IF (-zIIn2t1>=rsmall) THEN 
    16971704      zHen2t1 = 1._wp 
    … …  
    16991706      zHen2t1 = 0._wp 
    17001707      ENDIF 
    1701     
    1702       s11kr = (- zHen1t2 * zn1t2i11 - zHen2t1 * zn2t1i11) 
    1703  
    1704    END FUNCTION s11kr 
    1705  
    1706    FUNCTION s12kr(px,py,pz) 
     1708 
     1709      !!------------------------------------------------------------------- 
     1710      !! Function : s11kr 
     1711      !!------------------------------------------------------------------- 
     1712      allsk(1) = (- zHen1t2 * zn1t2i11 - zHen2t1 * zn2t1i11) 
    17071713      !!------------------------------------------------------------------- 
    17081714      !! Function : s12kr 
    17091715      !!------------------------------------------------------------------- 
    1710       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1711  
    1712       REAL(wp) ::   s12kr, zs12r0, zs21r0, zpih 
    1713  
    1714       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1715       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1716       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1717       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1718       REAL(wp) ::   zd11, zd12, zd22 
    1719       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1720       REAL(wp) ::   zHen1t2, zHen2t1 
    1721       !!------------------------------------------------------------------- 
    1722       zpih = 0.5_wp*rpi 
    1723     
    1724       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1725       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1726       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1727       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1728       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1729       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1730       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1731       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1732       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1733       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1734       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1735       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1736       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1737       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1738       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1739       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1740       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1741       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1742       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1743       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1744       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1745       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1746     
    1747       IF (-zIIn1t2>=rsmall) THEN 
    1748       zHen1t2 = 1._wp 
    1749       ELSE 
    1750       zHen1t2 = 0._wp 
    1751       ENDIF 
    1752     
    1753       IF (-zIIn2t1>=rsmall) THEN 
    1754       zHen2t1 = 1._wp 
    1755       ELSE 
    1756       zHen2t1 = 0._wp 
    1757       ENDIF 
    1758     
    17591716      zs12r0 = (- zHen1t2 * zn1t2i12 - zHen2t1 * zn2t1i12) 
    17601717      zs21r0 = (- zHen1t2 * zn1t2i21 - zHen2t1 * zn2t1i21) 
    1761       s12kr=0.5_wp*(zs12r0+zs21r0) 
    1762     
    1763    END FUNCTION s12kr 
    1764  
    1765    FUNCTION s22kr(px,py,pz) 
     1718      allsk(2)=0.5_wp*(zs12r0+zs21r0) 
    17661719      !!------------------------------------------------------------------- 
    17671720      !! Function : s22kr 
    17681721      !!------------------------------------------------------------------- 
    1769       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1770  
    1771       REAL(wp) ::   s22kr, zpih 
    1772  
    1773       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1774       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1775       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1776       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1777       REAL(wp) ::   zd11, zd12, zd22 
    1778       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1779       REAL(wp) ::   zHen1t2, zHen2t1 
    1780       !!------------------------------------------------------------------- 
    1781       zpih = 0.5_wp*rpi 
    1782  
    1783       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1784       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1785       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1786       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1787       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1788       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1789       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1790       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1791       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1792       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1793       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1794       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1795       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1796       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1797       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1798       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1799       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1800       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1801       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1802       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1803       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1804       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1805  
    1806       IF (-zIIn1t2>=rsmall) THEN 
    1807       zHen1t2 = 1._wp 
    1808       ELSE 
    1809       zHen1t2 = 0._wp 
    1810       ENDIF 
    1811  
    1812       IF (-zIIn2t1>=rsmall) THEN 
    1813       zHen2t1 = 1._wp 
    1814       ELSE 
    1815       zHen2t1 = 0._wp 
    1816       ENDIF 
    1817  
    1818       s22kr = (- zHen1t2 * zn1t2i22 - zHen2t1 * zn2t1i22) 
    1819  
    1820    END FUNCTION s22kr 
    1821  
    1822    FUNCTION s11ks(px,py,pz) 
     1722      allsk(3) = (- zHen1t2 * zn1t2i22 - zHen2t1 * zn2t1i22) 
    18231723      !!------------------------------------------------------------------- 
    18241724      !! Function : s11ks 
    18251725      !!------------------------------------------------------------------- 
    1826       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1827  
    1828       REAL(wp) ::   s11ks, zpih 
    1829  
    1830       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1831       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1832       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1833       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1834       REAL(wp) ::   zd11, zd12, zd22 
    1835       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1836       REAL(wp) ::   zHen1t2, zHen2t1 
    1837       !!------------------------------------------------------------------- 
    1838       zpih = 0.5_wp*rpi 
    1839  
    1840       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1841       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1842       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1843       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1844       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1845       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1846       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1847       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1848       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1849       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1850       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1851       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1852       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1853       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1854       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1855       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1856       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1857       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1858       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1859       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1860       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1861       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1862  
    1863       IF (-zIIn1t2>=rsmall) THEN 
    1864       zHen1t2 = 1._wp 
    1865       ELSE 
    1866       zHen1t2 = 0._wp 
    1867       ENDIF 
    1868  
    1869       IF (-zIIn2t1>=rsmall) THEN 
    1870       zHen2t1 = 1._wp 
    1871       ELSE 
    1872       zHen2t1 = 0._wp 
    1873       ENDIF 
    1874  
    1875       s11ks = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i11 + zHen2t1 * zt2t1i11) 
    1876  
    1877    END FUNCTION s11ks 
    1878  
    1879    FUNCTION s12ks(px,py,pz) 
     1726 
     1727      allsk(4) = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i11 + zHen2t1 * zt2t1i11) 
    18801728      !!------------------------------------------------------------------- 
    18811729      !! Function : s12ks 
    18821730      !!------------------------------------------------------------------- 
    1883       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1884  
    1885       REAL(wp) ::   s12ks, zs12s0, zs21s0, zpih 
    1886  
    1887       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1888       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1889       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1890       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1891       REAL(wp) ::   zd11, zd12, zd22 
    1892       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1893       REAL(wp) ::   zHen1t2, zHen2t1 
    1894       !!------------------------------------------------------------------- 
    1895       zpih = 0.5_wp*rpi 
    1896  
    1897       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1898       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1899       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1900       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1901       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1902       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1903       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1904       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1905       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1906       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1907       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1908       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1909       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1910       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1911       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1912       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1913       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1914       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1915       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1916       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1917       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1918       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1919  
    1920       IF (-zIIn1t2>=rsmall) THEN 
    1921       zHen1t2 = 1._wp 
    1922       ELSE 
    1923       zHen1t2 = 0._wp 
    1924       ENDIF 
    1925  
    1926       IF (-zIIn2t1>=rsmall) THEN 
    1927       zHen2t1 = 1._wp 
    1928       ELSE 
    1929       zHen2t1 = 0._wp 
    1930       ENDIF 
    1931  
    19321731      zs12s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i12 + zHen2t1 * zt2t1i12) 
    19331732      zs21s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i21 + zHen2t1 * zt2t1i21) 
    1934       s12ks=0.5_wp*(zs12s0+zs21s0) 
    1935  
    1936    END FUNCTION s12ks 
    1937  
    1938    FUNCTION s22ks(px,py,pz)  
     1733      allsk(5)=0.5_wp*(zs12s0+zs21s0) 
    19391734      !!------------------------------------------------------------------- 
    19401735      !! Function : s22ks 
    19411736      !!------------------------------------------------------------------- 
    1942       REAL(wp), INTENT(in   ) ::   px,py,pz 
    1943  
    1944       REAL(wp) ::   s22ks, zpih 
    1945  
    1946       REAL(wp) ::   zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 
    1947       REAL(wp) ::   zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 
    1948       REAL(wp) ::   zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i22 
    1949       REAL(wp) ::   zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i22 
    1950       REAL(wp) ::   zd11, zd12, zd22 
    1951       REAL(wp) ::   zIIn1t2, zIIn2t1, zIIt1t2 
    1952       REAL(wp) ::   zHen1t2, zHen2t1 
    1953       !!------------------------------------------------------------------- 
    1954       zpih = 0.5_wp*rpi 
    1955  
    1956       zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 
    1957       zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) 
    1958       zn1t2i21 = sin(pz+zpih-pphi) * cos(pz+pphi) 
    1959       zn1t2i22 = sin(pz+zpih-pphi) * sin(pz+pphi) 
    1960       zn2t1i11 = cos(pz-zpih+pphi) * cos(pz-pphi) 
    1961       zn2t1i12 = cos(pz-zpih+pphi) * sin(pz-pphi) 
    1962       zn2t1i21 = sin(pz-zpih+pphi) * cos(pz-pphi) 
    1963       zn2t1i22 = sin(pz-zpih+pphi) * sin(pz-pphi) 
    1964       zt1t2i11 = cos(pz-pphi) * cos(pz+pphi) 
    1965       zt1t2i12 = cos(pz-pphi) * sin(pz+pphi) 
    1966       zt1t2i21 = sin(pz-pphi) * cos(pz+pphi) 
    1967       zt1t2i22 = sin(pz-pphi) * sin(pz+pphi) 
    1968       zt2t1i11 = cos(pz+pphi) * cos(pz-pphi) 
    1969       zt2t1i12 = cos(pz+pphi) * sin(pz-pphi) 
    1970       zt2t1i21 = sin(pz+pphi) * cos(pz-pphi) 
    1971       zt2t1i22 = sin(pz+pphi) * sin(pz-pphi) 
    1972       zd11 = cos(py)*cos(py)*(cos(px)+sin(px)*tan(py)*tan(py)) 
    1973       zd12 = cos(py)*cos(py)*tan(py)*(-cos(px)+sin(px)) 
    1974       zd22 = cos(py)*cos(py)*(sin(px)+cos(px)*tan(py)*tan(py)) 
    1975       zIIn1t2 = zn1t2i11 * zd11 + (zn1t2i12 + zn1t2i21) * zd12 + zn1t2i22 * zd22 
    1976       zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 
    1977       zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 
    1978  
    1979       IF (-zIIn1t2>=rsmall) THEN 
    1980       zHen1t2 = 1._wp 
    1981       ELSE 
    1982       zHen1t2 = 0._wp 
    1983       ENDIF 
    1984  
    1985       IF (-zIIn2t1>=rsmall) THEN 
    1986       zHen2t1 = 1._wp 
    1987       ELSE 
    1988       zHen2t1 = 0._wp 
    1989       ENDIF 
    1990  
    1991       s22ks = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i22 + zHen2t1 * zt2t1i22) 
    1992  
    1993    END FUNCTION s22ks 
     1737      allsk(6) = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i22 + zHen2t1 * zt2t1i22) 
     1738   END SUBROUTINE all_skr_sks 
    19941739 
    19951740#else 
    … …  
    19971742   !!   Default option         Empty module           NO SI3 sea-ice model 
    19981743   !!---------------------------------------------------------------------- 
     1744   USE par_kind 
     1745   USE lib_mpp 
     1746   CONTAINS 
     1747   SUBROUTINE ice_dyn_rhg_eap( kt, Kmm, pstress1_i, pstress2_i, pstress12_i, pshear_i, pdivu_i, pdelta_i, paniso_11, paniso_12, prdg_conv ) 
     1748      INTEGER                 , INTENT(in   ) ::   kt                                    ! time step 
     1749      INTEGER                 , INTENT(in   ) ::   Kmm                                   ! ocean time level index 
     1750      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pstress1_i, pstress2_i, pstress12_i   ! 
     1751      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pshear_i  , pdivu_i   , pdelta_i      ! 
     1752      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   paniso_11 , paniso_12                 ! structure tensor components 
     1753      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   prdg_conv                             ! for ridging 
     1754      CALL ctl_stop('EAP rheology is currently dsabled due to issues with AGRIF preprocessing') 
     1755   END SUBROUTINE ice_dyn_rhg_eap 
     1756   SUBROUTINE rhg_eap_rst( cdrw, kt ) 
     1757      CHARACTER(len=*) , INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag 
     1758      INTEGER, OPTIONAL, INTENT(in) ::   kt     ! ice time-step 
     1759   END SUBROUTINE rhg_eap_rst 
    19991760#endif 
    20001761 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ICE_RHEO/cpp_ICE_RHEO.fcm

    r14021 r14200  
    1 bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput 
     1bld::tool::fppkeys key_si3 key_linssh key_mpp_mpi key_nosignedzero key_iomput 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/ISOMIP+/MY_SRC/eosbn2.F90

    r14010 r14200  
    9191 
    9292   !                               !!!  simplified eos coefficients (default value: Vallis 2006) 
    93    REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff.  
    94    REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff.  
     93   REAL(wp), PUBLIC ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff.  
     94   REAL(wp), PUBLIC ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff.  
    9595   REAL(wp) ::   rn_lambda1 = 5.9520e-2_wp     ! cabbeling coeff. in T^2         
    9696   REAL(wp) ::   rn_lambda2 = 5.4914e-4_wp     ! cabbeling coeff. in S^2         

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm

    r10425 r14200  
    1  bld::tool::fppkeys   key_iomput key_mpp_mpi  
     1 bld::tool::fppkeys   key_qco key_iomput key_mpp_mpi  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/OVERFLOW/cpp_OVERFLOW.fcm

    r10425 r14200  
    1 bld::tool::fppkeys   key_mpp_mpi key_iomput  
     1bld::tool::fppkeys   key_qco key_mpp_mpi key_iomput  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/STATION_ASF/cpp_STATION_ASF.fcm

    r14072 r14200  
    1  bld::tool::fppkeys   key_si3 key_c1d key_iomput key_mpp_mpi 
     1 bld::tool::fppkeys   key_si3 key_c1d key_qco key_iomput key_mpp_mpi 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/SWG/EXPREF/file_def_nemo-oce.xml

    r13752 r14200  
    4646        </file> 
    4747         
    48         <file id="file5" name_suffix="_grid_F" description="ocean F grid variables put on T grid" > 
    49           <field field_ref="e3f"            name="e3f"       operation = "instant" /> 
    50           <field field_ref="e3f_0"          name="e3f_0"     operation = "instant" /> 
    51           <field field_ref="hf"             name="hf"        operation = "instant" /> 
    52           <field field_ref="sKEf"           name="sKEf"      operation = "instant" /> 
    53           <field field_ref="relvor"         name="relvor"    operation = "instant" /> 
    54           <field field_ref="plavor"         name="plavor"    operation = "instant" /> 
    55           <field field_ref="abspotvor"      name="abspotvor" operation = "instant" /> 
    56           <field field_ref="relpotvor"      name="relpotvor" operation = "instant" /> 
    57           <field field_ref="Ens"            name="enstro"    operation = "instant" /> 
     48        <file id="file5" name_suffix="_grid_F" description="ocean F grid variables" > 
     49          <field field_ref="e3f"            name="e3f"         operation = "instant" /> 
     50          <field field_ref="e3f_0"          name="e3f_0"       operation = "instant" /> 
     51          <field field_ref="hf"             name="hf"          operation = "instant" /> 
     52          <field field_ref="ssKEf"          name="ssKEf"       operation = "instant" /> 
     53          <field field_ref="ssrelvor"       name="ssrelvor"    operation = "instant" /> 
     54          <field field_ref="ssplavor"       name="ssplavor"    operation = "instant" /> 
     55          <field field_ref="ssabspotvor"    name="ssabspotvor" operation = "instant" /> 
     56          <field field_ref="ssrelpotvor"    name="ssrelpotvor" operation = "instant" /> 
     57          <field field_ref="ssEns"          name="ssenstro"    operation = "instant" /> 
    5858        </file> 
    5959       

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/SWG/cpp_SWG.fcm

    r13752 r14200  
    1 bld::tool::fppkeys  key_mpp_mpi key_iomput key_qco  
     1bld::tool::fppkeys  key_mpp_mpi key_iomput key_qco key_RK3 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/VORTEX/MY_SRC/usrdef_istate.F90

    r14086 r14200  
    1717   USE dom_oce , ONLY : glamt, gphit, glamu, gphiu, glamv, gphiv   
    1818   USE phycst         ! physical constants 
     19   USE eosbn2  , ONLY : rn_a0 
    1920   ! 
    2021   USE in_out_manager ! I/O manager 
    … …  
    8586                  & * EXP(-(zx**2+zy**2)/zlambda**2) / (grav*(zH -1._wp + EXP(-zH))); 
    8687            ENDIF 
    87             pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
     88            pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / rn_a0 ) * ptmask(ji,jj,jk) 
    8889         END DO 
    8990      END_2D 

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/VORTEX/cpp_VORTEX.fcm

    r14053 r14200  
    1  bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif  
     1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif key_qco  

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/WAD/MY_DOCS/WAD_doc.tex

    • Property svn:executable deleted

  • NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/tests/WAD/cpp_WAD.fcm

    r10425 r14200  
    1  bld::tool::fppkeys   key_iomput key_mpp_mpi  
     1 bld::tool::fppkeys   key_iomput key_mpp_mpi key_qco  
Note: See TracChangeset for help on using the changeset viewer.