Changeset 14200
- Timestamp:
- 2020-12-17T15:36:44+01:00 (4 years ago)
- 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 1 bld::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 1 bld::tool::fppkeys key_top key_my_trc key_mpp_mpi key_iomput key_linssh 2 2 inc $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_iomput1 bld::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 1 bld::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 1 bld::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_mpi1 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 740 740 <!-- F grid --> 741 741 <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="s KEf" 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" /> 751 751 </field_group> 752 752 -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/cfgs/SHARED/namelist_ref
r14089 r14200 202 202 !! namsbc_wave external fields from wave model (ln_wave =T) 203 203 !! namberg iceberg floats (ln_icebergs=T) 204 !! namsbc_fwb freshwater-budget adjustment (nn_fwb > 0) 204 205 !!====================================================================== 205 206 ! … … 382 383 sn_rcv_isf = 'none' , 'no' , '' , '' , '' 383 384 sn_rcv_icb = 'none' , 'no' , '' , '' , '' 384 sn_rcv_hsig = 'none' , 'no' , '' ''' , 'T'385 sn_rcv_hsig = 'none' , 'no' , '' , '' , 'T' 385 386 sn_rcv_phioc = 'none' , 'no' , '' , '' , 'T' 386 387 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' 392 393 sn_rcv_charn = 'none' , 'no' , '' , '' , 'T' 393 394 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' 397 398 / 398 399 !----------------------------------------------------------------------- … … 653 654 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 654 655 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) 655 661 / 656 662 -
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 46 46 47 47 \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} 49 82 \caption{\forcode{&namdom_domcfg}} 50 83 \label{lst:namdom_domcfg} … … 383 416 \subsubsection[$S$-coordinate (\forcode{ln_sco})]{$S$-coordinate (\protect\np{ln_sco}{ln\_sco})} 384 417 \label{sec:DOMCFG_sco} 418 385 419 \begin{listing} 386 \nlst{namzgr_sco_domcfg}420 % \nlst{namzgr_sco_domcfg} 387 421 \caption{\forcode{&namzgr_sco_domcfg}} 388 422 \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} 389 450 \end{listing} 390 Options are defined in \nam{zgr_sco}{zgr\_sco} (\texttt{DOMAINcfg} only). 451 452 Options are defined in \forcode{&zgr_sco} (\texttt{DOMAINcfg} only). 391 453 In $s$-coordinate (\np[=.true.]{ln_sco}{ln\_sco}), the depth and thickness of the model levels are defined from 392 454 the 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 763 763 which imposes a very small time step when an explicit time stepping is used. 764 764 Two 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?}),765 the filtered free surface, which is a modification of the continuous equations \iffalse (see \autoref{eq:MB_flt?}) \fi 766 766 and the split-explicit free surface described below. 767 767 The 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 372 372 The number of boundary sets is defined by \np{nb_bdy}{nb\_bdy}. 373 373 Each 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). 375 375 The coordinates.bdy file is analagous to the usual \NEMO\ ``\ifile{coordinates}'' file. 376 376 In the example above, there are two boundary sets, the first of which is defined via a file and … … 569 569 \autoref{fig:LBC_bdy_geom} shows an example of an irregular boundary. 570 570 571 The boundary geometry for each set may be defined in a namelist nambdy\_indexor571 The boundary geometry for each set may be defined in a namelist \forcode{&nambdy_index} or 572 572 by reading in a ``\ifile{coordinates.bdy}'' file. 573 The nambdy\_indexnamelist defines a series of straight-line segments for north, east, south and west boundaries.574 One nambdy\_indexnamelist block is needed for each boundary condition defined by indexes.573 The \texttt{nambdy\_index} namelist defines a series of straight-line segments for north, east, south and west boundaries. 574 One \texttt{nambdy\_index} namelist block is needed for each boundary condition defined by indexes. 575 575 For the northern boundary, \texttt{nbdysegn} gives the number of segments, 576 576 \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 892 892 \subsubsection{Running} 893 893 894 The simplest way to use the executable is to edit and append the \ textbf{sao.nml} namelist to894 The simplest way to use the executable is to edit and append the \nam{sao}{sao} namelist to 895 895 a full \NEMO\ namelist and then to run the executable as if it were nemo.exe. 896 896 … … 914 914 For example, to read the second time counter from a single file the namelist would be. 915 915 916 \begin{forlines} 916 \begin{listing} 917 % \nlst{namsao} 918 \begin{forlines} 917 919 !---------------------------------------------------------------------- 918 920 ! namsao Standalone obs_oper namelist … … 924 926 nn_sao_idx = 2 925 927 / 926 \end{forlines} 928 \end{forlines} 929 \caption{\forcode{&namsao}} 930 \label{lst:namsao} 931 \end{listing} 927 932 928 933 %% ================================================================================================= … … 1119 1124 To plot some data run IDL and then: 1120 1125 1121 \begin{ minted}{idl}1126 \begin{verbatim} 1122 1127 IDL> dataplot, "filename" 1123 \end{ minted}1128 \end{verbatim} 1124 1129 1125 1130 To read multiple files into dataplot, … … 1127 1132 the easiest method is to use the spawn command to generate a list of files which can then be passed to dataplot. 1128 1133 1129 \begin{ minted}{idl}1134 \begin{verbatim} 1130 1135 IDL> spawn, 'ls profb*.nc', files 1131 1136 IDL> dataplot, files 1132 \end{ minted}1137 \end{verbatim} 1133 1138 1134 1139 \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 16 16 Release & Author(s) & Modifications \\ 17 17 \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] 19 19 {\em 4.0} & {\em ...} & {\em ...} \\ 20 20 {\em 3.6} & {\em ...} & {\em ...} \\ … … 664 664 For the cool-skin scheme parametrization COARE and ECMWF algorithms share the same 665 665 basis: \citet{fairall.bradley.ea_JGRO96}. With some minor updates based 666 on \citet{zeng.beljaars_GRL05} for ECMWF , and \citet{fairall.ea_19} for COARE666 on \citet{zeng.beljaars_GRL05} for ECMWF \iffalse, and \citet{fairall.ea_19?} for COARE \fi 667 667 3.6. 668 668 … … 671 671 turbulence input from Langmuir circulation). 672 672 673 Importantly, COARE warm-layer scheme \ citep{fairall.ea_19}includes a prognostic673 Importantly, COARE warm-layer scheme \iffalse \citep{fairall.ea_19?} \fi includes a prognostic 674 674 equation for the thickness of the warm-layer, while it is considered as constant 675 675 in the ECWMF algorithm. … … 971 971 and tidal analysis in the model framework. This includes the computation of the gravitational 972 972 surface forcing, as well as support for lateral forcing at open boundaries (see 973 \autoref{subsec:LBC_bdy_tides}) and tidal harmonic analysis (see974 \autoref{subsec:DIA_diamlr } and \autoref{subsec:DIA_diadetide}). The module is973 \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 975 975 activated with \np[=.true.]{ln_tide}{ln\_tide} in namelist 976 976 \nam{_tide}{\_tide}. It provides the same 34 tidal constituents that are … … 1777 1777 \label{subsec:SBC_fwb} 1778 1778 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 1785 For global ocean simulations, it can be useful to introduce a control of the 1786 mean sea level in order to prevent unrealistic drifting of the sea surface 1787 height due to unbalanced freshwater fluxes. In \NEMO, two options for 1788 controlling the freshwater budget are proposed. 1782 1789 1783 1790 \begin{description} 1784 \item [{\np[=0]{nn_fwb}{nn\_fwb}} ] no control at all.1785 The mean sea level isfree 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. 1787 1794 %GS: comment below still relevant ? 1788 1795 %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}. 1793 1803 \end{description} 1794 1804 -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_ZDF.tex
r14113 r14200 731 731 \subsubsection{Evolution of the boundary layer depth} 732 732 733 The prognostic equation for the depth of the neutral/unstable boundary layer is given by \ citep{grant+etal18},733 The prognostic equation for the depth of the neutral/unstable boundary layer is given by \iffalse \citep{grant+etal18?}, \fi 734 734 735 735 \begin{equation} … … 747 747 equation for the case when the pycnocline has a finite thickness, 748 748 based on the potential energy budget of the OSBL, is the leading term 749 \ citep{grant+etal18}of a generalization of that used in mixed-layer749 \iffalse \citep{grant+etal18?} \fi of a generalization of that used in mixed-layer 750 750 models e.g.\ \citet{kraus.turner_T67}, in which the thickness of the pycnocline is taken to be zero. 751 751 -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/NEMO/subfiles/chap_cfgs.tex
r14113 r14200 243 243 Through \np[=.false.]{ln_read_cfg}{ln\_read\_cfg} in \nam{cfg}{cfg} namelist defined in 244 244 the reference configuration \path{./cfgs/GYRE_PISCES/EXPREF/namelist_cfg} 245 analytical definition of grid in GYRE is done in usrdef\_hrg, usrdef\_zgrroutines.245 analytical definition of grid in GYRE is done in mdl{usrdef\_hrg}, \mdl{usrdef\_zgr} routines. 246 246 Its 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 \\247 setting \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*} 252 252 253 253 Obviously, the namelist parameters have to be adjusted to the chosen resolution, 254 254 see the Configurations pages on the \NEMO\ web site (\NEMO\ Configurations). 255 255 In 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} 256 270 257 271 The 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 95 95 which imposes a very small time step when an explicit time stepping is used. 96 96 Two 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?}),97 the filtered free surface, which is a modification of the continuous equations \iffalse (see \autoref{eq:MB_flt?}) \fi , 98 98 and the split-explicit free surface described below. 99 99 The 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 2 2 &namdyn_adv ! Ice advection 3 3 !------------------------------------------------------------------------------ 4 ln_adv_Pra = .true. ! Advection scheme (Prather)5 ln_adv_UMx = .false. 4 ln_adv_Pra = .true. ! Advection scheme (Prather) 5 ln_adv_UMx = .false. ! Advection scheme (Ultimate-Macho) 6 6 nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) 7 7 / -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/doc/latex/SI3/namelists/namsbc
r11026 r14200 3 3 !------------------------------------------------------------------------------ 4 4 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 6 10 ! = 1 => no snow blowing, < 1 => some snow blowing 7 11 nn_flxdist = -1 ! Redistribute heat flux over ice categories … … 12 16 ln_cndflx = .false. ! Use conduction flux as surface boundary conditions (i.e. for Jules coupling) 13 17 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) 14 21 / -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/ICE/icedyn_rhg_eap.F90
r14072 r14200 16 16 !! CICE code (Tsamados, Heorton) 17 17 !!---------------------------------------------------------------------- 18 #if defined key_si3 && ! defined key_agrif18 #if defined key_si3 19 19 !!---------------------------------------------------------------------- 20 20 !! 'key_si3' SI3 sea-ice model … … 66 66 INTEGER :: ncvgid ! netcdf file id 67 67 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 69 70 !!---------------------------------------------------------------------- 70 71 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 202 203 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_eap: EAP sea-ice rheology' 203 204 ! 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 ! 206 213 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 209 215 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 210 221 ! 211 222 !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... … … 349 360 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) 350 361 ! 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 352 363 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 353 364 ! 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 355 366 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 356 367 ! 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 358 369 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 359 370 END_2D … … 749 760 750 761 ! 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 ) 752 763 ! 753 764 ! ! ==================== ! … … 819 830 & ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 820 831 ! 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 ) 827 838 ENDIF 828 839 829 840 ! --- divergence, shear and strength --- ! 830 IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence831 IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear832 IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , pdelta_i * zmsk00 ) ! delta833 IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength841 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 834 845 835 846 ! --- Stress tensor invariants (SIMIP diags) --- ! … … 856 867 ! 857 868 ! 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 stress859 IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress869 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 860 871 861 872 DEALLOCATE ( zsig_I, zsig_II ) … … 903 914 CALL lbc_lnk_multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 904 915 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 ) 908 919 ENDIF 909 920 … … 911 922 IF( iom_use('aniso') ) THEN 912 923 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 ) 914 925 ENDIF 915 926 … … 922 933 & zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 923 934 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) 930 941 ENDIF 931 942 … … 938 949 DO_2D( 0, 0, 0, 0 ) 939 950 ! 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) 942 953 943 954 zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component … … 973 984 IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 974 985 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(:,:) ) 976 987 ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 977 988 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(:,:) ) 979 990 ENDIF 980 991 ENDIF 981 992 ENDIF 982 993 ! 983 DEALLOCATE( zmsk00, zmsk15 )984 !985 994 END SUBROUTINE ice_dyn_rhg_eap 986 995 987 996 988 SUBROUTINE rhg_cvg ( kt, kiter, kitermax, pu, pv, pub, pvb )997 SUBROUTINE rhg_cvg_eap( kt, kiter, kitermax, pu, pv, pub, pvb ) 989 998 !!---------------------------------------------------------------------- 990 !! *** ROUTINE rhg_cvg ***999 !! *** ROUTINE rhg_cvg_eap *** 991 1000 !! 992 1001 !! ** Purpose : check convergence of oce rheology … … 1006 1015 REAL(wp) :: zresm ! local real 1007 1016 CHARACTER(len=20) :: clname 1008 REAL(wp), DIMENSION(jpi,jpj) :: zres ! check convergence1009 1017 !!---------------------------------------------------------------------- 1010 1018 … … 1014 1022 IF( lwp ) THEN 1015 1023 WRITE(numout,*) 1016 WRITE(numout,*) 'rhg_cvg : ice rheology convergence control'1024 WRITE(numout,*) 'rhg_cvg_eap : ice rheology convergence control' 1017 1025 WRITE(numout,*) '~~~~~~~' 1018 1026 ENDIF … … 1037 1045 ELSE 1038 1046 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) 1041 1049 END_2D 1042 zresm = MAXVAL( zres ) 1050 1051 zresm = MAXVAL( eap_res ) 1043 1052 CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain 1044 1053 ENDIF … … 1051 1060 ENDIF 1052 1061 1053 END SUBROUTINE rhg_cvg 1062 END SUBROUTINE rhg_cvg_eap 1054 1063 1055 1064 … … 1080 1089 REAL(wp) :: zsig11, zsig12, zsig22 1081 1090 REAL(wp) :: zsgprm11, zsgprm12, zsgprm22 1082 REAL(wp) :: zinvstressconviso1083 1091 REAL(wp) :: zAngle_denom_gamma, zAngle_denom_alpha 1084 1092 REAL(wp) :: zTany_1, zTany_2 1085 REAL(wp) :: zx, zy, z dx, zdy, zda, zkxw, kyw, kaw1093 REAL(wp) :: zx, zy, zkxw, kyw, kaw 1086 1094 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 1091 1098 ! Factor to maintain the same stress as in EVP (see Section 3) 1092 1099 ! Can be set to 1 otherwise 1093 ! zinvstressconviso = 1._wp/(1._wp+kfriction*kfriction)1094 zinvstressconviso = 1._wp1095 1096 zinvsin = 1._wp/sin(2._wp*pphi) * zinvstressconviso1097 !now uses phi as set in higher code1100 ! 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 1098 1105 1099 1106 ! compute eigenvalues, eigenvectors and angles for structure tensor, strain … … 1175 1182 1176 1183 ! 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) 1183 1187 1184 1188 ! % need 8 coords and 8 weights … … 1258 1262 ! Tsamados 2013) 1259 1263 1260 zsig11 = pstrength*(zstemp11r + kfriction*zstemp11s) * zinvsin1261 zsig12 = pstrength*(zstemp12r + kfriction*zstemp12s) * zinvsin1262 zsig22 = pstrength*(zstemp22r + kfriction*zstemp22s) * zinvsin1264 zsig11 = pstrength*(zstemp11r + ppkfriction*zstemp11s) * ppinvsin 1265 zsig12 = pstrength*(zstemp12r + ppkfriction*zstemp12s) * ppinvsin 1266 zsig22 = pstrength*(zstemp22r + ppkfriction*zstemp22s) * ppinvsin 1263 1267 1264 1268 ! Back - rotation of the stress from principal axes into general coordinates … … 1319 1323 REAL (wp) :: zQ11, zQ12, zQ11Q11, zQ11Q12, zQ12Q12 1320 1324 1321 !!$ REAL (wp), PARAMETER ::kfrac = 0.0001_wp ! rate of fracture formation1322 REAL (wp), PARAMETER :: kfrac = 1.e-3_wp! rate of fracture formation1323 REAL (wp), PARAMETER :: threshold = 0.3_wp ! critical confinement ratio1325 !!$ 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 1324 1328 !!--------------------------------------------------------------- 1325 1329 ! … … 1363 1367 ! which leads to the loss of their shape, so we again model it through diffusion 1364 1368 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) 1367 1371 1368 1372 ! Shear faulting … … 1370 1374 pmresult11 = 0.0_wp 1371 1375 pmresult12 = 0.0_wp 1372 ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= threshold)) THEN1373 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) 1375 1379 1376 1380 ! Horizontal spalling … … 1405 1409 !!clem 1406 1410 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 1408 1413 1409 1414 REAL(wp), PARAMETER :: eps6 = 1.0e-6_wp … … 1522 1527 zw2 = w2(ainit+ia*da) 1523 1528 DO iz = 1, nz 1524 idz = zinit+iz*dz1529 zidz = zinit+iz*dz 1525 1530 ztemp = zw1 * EXP(-zw2*(zinit+iz*dz)*(zinit+iz*dz)) 1526 1531 DO iy = 1, ny_yield 1527 idy = yinit+iy*dy1532 zidy = yinit+iy*dy 1528 1533 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) 1536 1543 END DO 1537 1544 END DO 1538 1545 END DO 1539 1546 END DO 1540 1541 1547 zfac = 1._wp/sin(2._wp*pphi) 1542 1548 ia = na_yield 1543 1549 DO iy = 1, ny_yield 1544 idy = yinit+iy*dy1550 zidy = yinit+iy*dy 1545 1551 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) 1553 1561 ENDDO 1554 1562 ENDDO … … 1616 1624 END FUNCTION w2 1617 1625 1618 FUNCTION s11kr(px,py,pz) 1619 !!------------------------------------------------------------------- 1620 !! Function : s11kr 1621 !!------------------------------------------------------------------- 1626 SUBROUTINE all_skr_sks( px, py, pz, allsk ) 1622 1627 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 1626 1634 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 1627 1635 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 … … 1673 1681 ENDIF 1674 1682 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) 1680 1687 !!------------------------------------------------------------------- 1681 1688 !! Function : s12kr 1682 1689 !!------------------------------------------------------------------- 1683 REAL(wp), INTENT(in ) :: px,py,pz1684 1685 REAL(wp) :: s12kr, zs12r0, zs21r0, zpih1686 1687 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i221688 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i221689 REAL(wp) :: zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i221690 REAL(wp) :: zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i221691 REAL(wp) :: zd11, zd12, zd221692 REAL(wp) :: zIIn1t2, zIIn2t1, zIIt1t21693 REAL(wp) :: zHen1t2, zHen2t11694 !!-------------------------------------------------------------------1695 zpih = 0.5_wp*rpi1696 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 * zd221717 zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd221718 zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd221719 1720 IF (-zIIn1t2>=rsmall) THEN1721 zHen1t2 = 1._wp1722 ELSE1723 zHen1t2 = 0._wp1724 ENDIF1725 1726 IF (-zIIn2t1>=rsmall) THEN1727 zHen2t1 = 1._wp1728 ELSE1729 zHen2t1 = 0._wp1730 ENDIF1731 1732 1690 zs12r0 = (- zHen1t2 * zn1t2i12 - zHen2t1 * zn2t1i12) 1733 1691 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) 1739 1693 !!------------------------------------------------------------------- 1740 1694 !! Function : s22kr 1741 1695 !!------------------------------------------------------------------- 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) 1796 1697 !!------------------------------------------------------------------- 1797 1698 !! Function : s11ks 1798 1699 !!------------------------------------------------------------------- 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) 1853 1702 !!------------------------------------------------------------------- 1854 1703 !! Function : s12ks 1855 1704 !!------------------------------------------------------------------- 1856 REAL(wp), INTENT(in ) :: px,py,pz1857 1858 REAL(wp) :: s12ks, zs12s0, zs21s0, zpih1859 1860 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i221861 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i221862 REAL(wp) :: zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i221863 REAL(wp) :: zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i221864 REAL(wp) :: zd11, zd12, zd221865 REAL(wp) :: zIIn1t2, zIIn2t1, zIIt1t21866 REAL(wp) :: zHen1t2, zHen2t11867 !!-------------------------------------------------------------------1868 zpih = 0.5_wp*rpi1869 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 * zd221890 zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd221891 zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd221892 1893 IF (-zIIn1t2>=rsmall) THEN1894 zHen1t2 = 1._wp1895 ELSE1896 zHen1t2 = 0._wp1897 ENDIF1898 1899 IF (-zIIn2t1>=rsmall) THEN1900 zHen2t1 = 1._wp1901 ELSE1902 zHen2t1 = 0._wp1903 ENDIF1904 1905 1705 zs12s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i12 + zHen2t1 * zt2t1i12) 1906 1706 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) 1912 1708 !!------------------------------------------------------------------- 1913 1709 !! Function : s22ks 1914 1710 !!------------------------------------------------------------------- 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 1967 1713 1968 1714 #else -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/ICE/iceistate.F90
r14086 r14200 22 22 USE eosbn2 ! equation of state 23 23 # 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. 25 27 # else 26 28 USE domvvl ! Variable volume … … 424 426 ! 425 427 #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. 427 431 #else 428 432 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 69 69 Agrif_UseSpecialValue = .FALSE. 70 70 ! lbc ???? 71 ! JC: do we really need the 3 lines below ?71 ! 72 72 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 ! 91 74 END SUBROUTINE agrif_istate_ice 92 75 -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_interp.F90
r14086 r14200 76 76 IF(lwp) WRITE(numout,*) ' ' 77 77 78 IF ( ln_rstart ) &79 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')80 81 78 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 82 79 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') … … 86 83 Agrif_UseSpecialValue = .TRUE. 87 84 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 92 88 93 89 Krhs_a = Kbb ; Kmm_a = Kbb 94 90 95 91 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 96 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)97 92 98 93 Agrif_UseSpecialValue = ln_spc_dyn … … 108 103 Krhs_a = Kaa ; Kmm_a = Kmm 109 104 110 ssh(:,:,Kbb) = ssh(:,:,Kbb) * tmask(:,:,1)111 112 105 DO jn = 1, jpts 113 106 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:) … … 118 111 CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 119 112 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 )121 113 122 114 END SUBROUTINE Agrif_istate_oce 123 115 124 116 125 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm )117 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa ) 126 118 !!---------------------------------------------------------------------- 127 119 !! *** ROUTINE agrif_istate_ssh *** … … 132 124 IMPLICIT NONE 133 125 ! 134 INTEGER, INTENT(in) :: Kbb, Kmm 126 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 135 127 !!---------------------------------------------------------------------- 136 128 IF(lwp) WRITE(numout,*) ' ' … … 139 131 IF(lwp) WRITE(numout,*) ' ' 140 132 141 IF ( ln_rstart ) &142 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')143 144 133 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 145 134 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 146 135 147 Kmm_a = Kmm 148 ssh(:,:,Kmm) = 0._wp 149 136 Krhs_a = Kbb ; Kmm_a = Kbb 137 ! 150 138 Agrif_SpecialValue = 0._wp 151 139 Agrif_UseSpecialValue = .TRUE. 152 140 l_ini_child = .TRUE. 153 141 ! 142 ssh(:,:,Kbb) = 0._wp 154 143 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 155 144 ! 156 145 Agrif_UseSpecialValue = .FALSE. 157 146 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 159 154 160 155 END SUBROUTINE Agrif_istate_ssh … … 203 198 204 199 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 206 202 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 207 203 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) … … 274 270 IF( .NOT.ln_dynspg_ts ) THEN 275 271 DO ji = mi0(ibdy1), mi1(ibdy2) 276 uu_b(ji,:,Krhs_a) = 0._wp277 DO jk = 1, jpkm1278 DO jj = 1, jpj279 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 DO281 END DO282 272 DO jj = 1, jpj 283 273 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) … … 304 294 ! 305 295 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 306 ibdy2 = jpiglo - ( nn_hls + 1 ) ! 296 ibdy2 = jpiglo - ( nn_hls + 1 ) 297 ! 307 298 IF( .NOT.ln_dynspg_ts ) THEN 308 299 DO ji = mi0(ibdy1), mi1(ibdy2) 309 vv_b(ji,:,Krhs_a) = 0._wp310 DO jk = 1, jpkm1311 DO jj = 1, jpj312 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 DO314 END DO315 300 DO jj = 1, jpj 316 301 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) … … 318 303 END DO 319 304 ENDIF 320 305 ! 321 306 DO ji = mi0(ibdy1), mi1(ibdy2) 322 307 zvb(ji,:) = 0._wp … … 345 330 IF( .NOT.ln_dynspg_ts ) THEN 346 331 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) 356 335 END DO 357 336 END DO … … 401 380 IF( .NOT.ln_dynspg_ts ) THEN 402 381 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 410 383 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 411 384 END DO … … 432 405 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 433 406 jbdy2 = jpjglo - ( nn_hls + 1 ) 407 ! 434 408 IF( .NOT.ln_dynspg_ts ) THEN 435 409 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 443 411 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 444 412 END DO 445 413 END DO 446 414 ENDIF 447 415 ! 448 416 DO jj = mj0(jbdy1), mj1(jbdy2) 449 417 zub(:,jj) = 0._wp … … 651 619 IF( ll_int_cons ) THEN ! Conservative interpolation 652 620 IF ( lk_tint2d_notinterp ) THEN 621 Agrif_UseSpecialValue = .FALSE. 653 622 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const ) 654 623 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 655 624 ! 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 ) 658 627 ELSE 659 628 ! order matters here !!!!!! … … 990 959 ELSE 991 960 IF( l_ini_child ) THEN 992 ssh(i1:i2,j1:j2,K mm_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) 993 962 ELSE 994 963 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) … … 1438 1407 ptab(:,:) = 0._wp 1439 1408 DO ji=i1+1,i2-1 1440 DO jj=j1+1,j2 1409 DO jj=j1+1,j2-1 1441 1410 ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj )*e1v(ji+1,jj ) & 1442 1411 & -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) & … … 1542 1511 ptab(:,:) = 0._wp 1543 1512 DO ji=i1+1,i2-1 1544 DO jj=j1+1,j2 1513 DO jj=j1+1,j2-1 1545 1514 ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji ,jj+1)*e2u(ji ,jj+1) & 1546 1515 & -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 441 441 N_in = mbkt_parent(ji,jj) 442 442 ! 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 447 448 448 ! Intermediate grid:449 DO jk = 1, N_in450 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 DO453 z_in_i(1) = 0.5_wp * h_in_i(1)454 DO jk=2,N_in455 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )456 END DO457 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 459 460 ! Output (Child) grid: 460 461 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 192 192 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 193 193 ! 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 195 201 Agrif_UseSpecialValueInUpdate = .TRUE. 196 202 Agrif_SpecialValueFineGrid = 0. … … 204 210 CALL Agrif_ChildGrid_To_ParentGrid() 205 211 CALL dom_vvl_update_UVF 206 CALL Agrif_ParentGrid_To_ChildGrid()207 #else208 CALL Agrif_ChildGrid_To_ParentGrid()209 CALL Agrif_Update_qco210 212 CALL Agrif_ParentGrid_To_ChildGrid() 211 213 #endif … … 232 234 233 235 234 #if ! defined key_qco 236 #if ! defined key_qco && ! defined key_linssh 235 237 SUBROUTINE dom_vvl_update_UVF 236 238 !!--------------------------------------------- … … 1163 1165 END SUBROUTINE updateAVM 1164 1166 1165 #if ! defined key_qco 1167 #if ! defined key_qco && ! defined key_linssh 1166 1168 SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 1167 1169 !!--------------------------------------------- -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_top_interp.F90
r14086 r14200 27 27 PUBLIC Agrif_trc, interptrn 28 28 29 !! * Substitutions 30 # include "domzgr_substitute.h90" 29 31 !!---------------------------------------------------------------------- 30 32 !! 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 30 30 PUBLIC Agrif_Sponge_trc, interptrn_sponge 31 31 32 !! * Substitutions 33 # include "domzgr_substitute.h90" 32 34 !!---------------------------------------------------------------------- 33 35 !! NEMO/NST 4.0 , NEMO Consortium (2018) … … 128 130 N_in = mbkt_parent(ji,jj) 129 131 ! 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 134 137 135 ! Intermediate grid:136 DO jk = 1, N_in137 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 DO140 z_in_i(1) = 0.5_wp * h_in_i(1)141 DO jk=2,N_in142 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )143 END DO144 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 146 149 ! Output (Child) grid: 147 150 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 26 26 PUBLIC Agrif_Update_Trc 27 27 28 !! * Substitutions 29 # include "domzgr_substitute.h90" 28 30 !!---------------------------------------------------------------------- 29 31 !! 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 365 365 use_sign_north = .TRUE. 366 366 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 367 369 CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 368 370 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 ubdy370 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) ! must be called before vnb_id to define vbdy371 371 use_sign_north = .FALSE. 372 372 ubdy(:,:) = 0._wp 373 373 vbdy(:,:) = 0._wp 374 ELSE 374 ELSEIF ( ln_dynspg_EXP ) THEN 375 375 Agrif_UseSpecialValue = ln_spc_dyn 376 376 use_sign_north = .TRUE. 377 377 sign_north = -1. 378 ubdy(:,:) = 0._wp 379 vbdy(:,:) = 0._wp 378 380 CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 379 381 CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb ) … … 875 877 ! 876 878 ! 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' ) 877 881 IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', & 878 882 & '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 162 162 ! 163 163 ! SSH fields 164 IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain165 clfile = TRIM(filtide)//'_grid_T.nc'166 CALL iom_open( clfile , inum )167 igrd = 1 ! Everything is at T-points here168 DO itide = 1, nb_harmo169 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 171 171 DO ib = 1, SIZE(dta%ssh) 172 172 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 175 175 td%ssh0(ib,itide,2) = zti(ii,ij) 176 176 END DO 177 END DO178 CALL iom_close( inum )179 ENDIF177 ENDIF 178 END DO 179 CALL iom_close( inum ) 180 180 ! 181 181 ! U fields 182 IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain183 clfile = TRIM(filtide)//'_grid_U.nc'184 CALL iom_open( clfile , inum )185 igrd = 2 ! Everything is at U-points here186 DO itide = 1, nb_harmo187 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 189 189 DO ib = 1, SIZE(dta%u2d) 190 190 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 193 193 td%u0(ib,itide,2) = zti(ii,ij) 194 194 END DO 195 END DO196 CALL iom_close( inum )197 ENDIF195 ENDIF 196 END DO 197 CALL iom_close( inum ) 198 198 ! 199 199 ! V fields 200 IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain201 clfile = TRIM(filtide)//'_grid_V.nc'202 CALL iom_open( clfile , inum )203 igrd = 3 ! Everything is at V-points here204 DO itide = 1, nb_harmo205 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 207 207 DO ib = 1, SIZE(dta%v2d) 208 208 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 211 211 td%v0(ib,itide,2) = zti(ii,ij) 212 212 END DO 213 END DO214 CALL iom_close( inum )215 ENDIF213 ENDIF 214 END DO 215 CALL iom_close( inum ) 216 216 ! 217 217 DEALLOCATE( ztr, zti ) -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DIA/diawri.F90
r14086 r14200 215 215 ENDIF 216 216 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) 220 218 221 219 IF ( iom_use("taubot") ) THEN ! bottom stress … … 360 358 ENDIF 361 359 ! 362 IF ( iom_use("s KEf") ) THEN ! surface kinetic energy at F point360 IF ( iom_use("ssKEf") ) THEN ! surface kinetic energy at F point 363 361 z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry 364 362 DO_2D( 0, 0, 0, 0 ) … … 370 368 END_2D 371 369 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 372 CALL iom_put( "s KEf", z2d )370 CALL iom_put( "ssKEf", z2d ) 373 371 ENDIF 374 372 ! … … 473 471 IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging 474 472 475 ! Output of vorticity terms476 IF ( iom_use(" relvor") .OR. iom_use("plavor") .OR. &477 & iom_use(" relpotvor") .OR. iom_use("abspotvor") .OR. &478 & iom_use(" Ens") ) THEN473 ! 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 479 477 ! 480 478 z2d(:,:) = 0._wp … … 485 483 END_2D 486 484 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 ) 490 488 ! 491 489 DO_2D( 1, 0, 1, 0 ) … … 498 496 END_2D 499 497 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) 501 499 ! 502 500 DO_2D( 1, 0, 1, 0 ) … … 509 507 END_2D 510 508 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 ) 512 510 ! 513 511 DO_2D( 1, 0, 1, 0 ) … … 515 513 END_2D 516 514 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 ) 518 516 ! 519 517 ENDIF -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/dom_oce.F90
r14072 r14200 136 136 ! 137 137 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s] 138 138 139 !!---------------------------------------------------------------------- 139 140 !! vertical coordinate and scale factors 140 141 !! --------------------------------------------------------------------- 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 141 152 LOGICAL, PUBLIC :: ln_zco !: z-coordinate - full step 142 153 LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step … … 151 162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m] 152 163 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) 155 166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e3t, e3u, e3v, e3w, e3uw, e3vw !: vert. scale factor [m] 156 167 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) 159 170 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-] 160 171 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] … … 165 176 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] 166 177 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) 168 180 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw 169 181 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w … … 174 186 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] 175 187 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] 176 ! ! time-dependent heights of ocean water column177 #if ! defined key_qco 188 189 ! ! time-dependent heights of ocean water column (domvvl) 178 190 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m] 179 #endif180 191 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m] 181 192 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m] … … 207 218 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 208 219 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 212 222 !!---------------------------------------------------------------------- 213 223 !! calendar variables … … 301 311 ! 302 312 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) ) 309 324 ! 310 325 #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 314 336 #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 ! 315 341 ii = ii+1 316 342 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & 317 343 & 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) ) 328 348 #endif 329 349 ! … … 332 352 ! 333 353 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) , & 338 355 & 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) ) 340 357 ! 341 358 ii = ii+1 … … 348 365 ii = ii+1 349 366 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 350 #if defined key_qco351 !352 ii = ii+1353 ALLOCATE( fe3mask(jpi,jpj,jpk) , STAT=ierr(ii) )354 #endif355 367 ! 356 368 dom_oce_alloc = MAXVAL(ierr) -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domain.F90
r14090 r14200 28 28 USE oce ! ocean variables 29 29 USE dom_oce ! domain: ocean 30 USE domtile ! tiling utilities 30 31 #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. 32 35 #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 36 41 USE sbc_oce ! surface boundary condition: ocean 37 42 USE trc_oce ! shared ocean & passive tracers variab … … 39 44 USE domhgr ! domain: set the horizontal mesh 40 45 USE domzgr ! domain: set the vertical mesh 41 USE domtile42 46 USE dommsk ! domain: set the mask system 43 47 USE domwri ! domain: write the meshmask file … … 51 55 USE lbclnk ! ocean lateral boundary condition (or mpp link) 52 56 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 54 58 55 59 IMPLICIT NONE … … 169 173 DO_2D( 1, 1, 1, 1 ) 170 174 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' ) 172 176 ENDIF 173 177 END_2D … … 177 181 ! 178 182 ! != 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 182 185 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 ! 185 195 #if defined key_qco 186 196 ! != Quasi-Euerian coordinate case 187 197 ! 188 198 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 189 201 #else 190 202 ! … … 345 357 IF(lwm) WRITE( numond, namdom ) 346 358 ! 359 #if defined key_linssh 360 ln_linssh = lk_linssh ! overwrite ln_linssh with the logical associated with key_linssh 361 #endif 362 ! 347 363 #if defined key_agrif 348 364 IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep … … 371 387 ! 372 388 #if defined key_qco 373 IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh = Tare incompatible' )389 IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) 374 390 #endif 375 391 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domqco.F90
r14053 r14200 116 116 ! !== Set of all other vertical scale factors ==! (now and before) 117 117 ! ! 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 118 122 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 119 123 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) 124 #endif 120 125 ! 121 126 END SUBROUTINE dom_qco_zgr -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/domvvl.F90
r14086 r14200 2 2 !!====================================================================== 3 3 !! *** MODULE domvvl *** 4 !! Ocean : 4 !! Ocean : 5 5 !!====================================================================== 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code … … 26 26 USE timing ! Timing 27 27 28 #if defined key_agrif29 USE agrif_oce ! initial state interpolation30 USE agrif_oce_interp31 #endif32 33 28 IMPLICIT NONE 34 29 PRIVATE … … 55 50 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence 56 51 57 #if defined key_qco 52 #if defined key_qco || defined key_linssh 58 53 !!---------------------------------------------------------------------- 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 60 57 !!---------------------------------------------------------------------- 61 58 #else … … 63 60 !! Default key Old management of time varying vertical coordinate 64 61 !!---------------------------------------------------------------------- 65 62 66 63 !!---------------------------------------------------------------------- 67 64 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness … … 78 75 PUBLIC dom_vvl_sf_update ! called by step.F90 79 76 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 80 77 81 78 !! * Substitutions 82 79 # include "do_loop_substitute.h90" … … 114 111 !!---------------------------------------------------------------------- 115 112 !! *** ROUTINE dom_vvl_init *** 116 !! 113 !! 117 114 !! ** Purpose : Initialization of all scale factors, depths 118 115 !! and water column heights … … 123 120 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 124 121 !! - Regrid: e3[u/v](:,:,:,Kmm) 125 !! e3[u/v](:,:,:,Kmm) 126 !! e3w(:,:,:,Kmm) 122 !! e3[u/v](:,:,:,Kmm) 123 !! e3w(:,:,:,Kmm) 127 124 !! e3[u/v]w_b 128 !! e3[u/v]w_n 125 !! e3[u/v]w_n 129 126 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 130 127 !! - h(t/u/v)_0 … … 156 153 !!---------------------------------------------------------------------- 157 154 !! *** ROUTINE dom_vvl_init *** 158 !! 159 !! ** Purpose : Interpolation of all scale factors, 155 !! 156 !! ** Purpose : Interpolation of all scale factors, 160 157 !! depths and water column heights 161 158 !! … … 164 161 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 165 162 !! - 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 170 167 !! gdept_n, gdepw_n and gde3w_n 171 168 !! - h(t/u/v)_0 … … 185 182 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 186 183 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 188 185 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 189 186 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 191 188 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 192 189 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) … … 210 207 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 211 208 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 212 ! ! 0.5 where jk = mikt 209 ! ! 0.5 where jk = mikt 213 210 !!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ?? 214 211 zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 215 212 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 216 213 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)) 218 215 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 219 216 gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 220 217 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)) 222 219 END_3D 223 220 ! … … 278 275 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 279 276 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 281 278 ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls 282 279 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp … … 290 287 291 288 292 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 289 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 293 290 !!---------------------------------------------------------------------- 294 291 !! *** ROUTINE dom_vvl_sf_nxt *** 295 !! 292 !! 296 293 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 297 294 !! tranxt and dynspg routines 298 295 !! 299 296 !! ** 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 = 301 298 !! high frequency part of horizontal divergence 302 299 !! + retsoring towards the background grid … … 306 303 !! 307 304 !! ** 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 309 306 !! in z_tilde case 310 307 !! - e3(t/u/v)_a … … 410 407 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 411 408 & * ( 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) & 413 410 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 414 411 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) … … 455 452 WRITE(numout, *) 'at i, j, k=', ijk_max 456 453 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 458 455 CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 459 456 ENDIF … … 571 568 !!---------------------------------------------------------------------- 572 569 !! *** 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 575 572 !! compute all depths and related variables for next time step 576 573 !! write outputs and restart file … … 582 579 !! ** Action : - tilde_e3t_(b/n) ready for next time step 583 580 !! - 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 588 585 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 589 586 !! h(u/v) and h(u/v)r … … 616 613 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 617 614 ELSE 618 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 615 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 619 616 & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 620 617 ENDIF … … 628 625 ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 629 626 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 630 627 631 628 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 632 629 633 630 ! Vertical scale factor interpolations 634 631 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) … … 649 646 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 650 647 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) ) 652 649 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 653 650 END_3D … … 768 765 !!--------------------------------------------------------------------- 769 766 !! *** ROUTINE dom_vvl_rst *** 770 !! 767 !! 771 768 !! ** Purpose : Read or write VVL file in restart file 772 769 !! … … 800 797 IF( ln_rstart ) THEN !== Read the restart file ==! 801 798 ! 802 #if defined key_agrif803 IF ( (.NOT.Agrif_root()).AND.(ln_init_chfrpar) ) THEN804 ! skip reading restart if initialized from parent:805 id3 = -1 ; id4 = -1 ; id5 = -1806 ELSE807 #endif808 799 CALL rst_read_open !* open the restart file if necessary 809 800 ! ! --------- ! … … 815 806 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) 816 807 ! 817 #if defined key_agrif818 ENDIF819 #endif820 808 ! !* scale factors 821 809 IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' 822 810 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 823 WHERE ( tmask(:,:,:) == 0.0_wp ) 811 WHERE ( tmask(:,:,:) == 0.0_wp ) 824 812 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 825 813 END WHERE 826 814 IF( l_1st_euler ) THEN ! euler 827 815 IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)' 828 e3t(:,:,:,K mm) = e3t(:,:,:,Kbb)816 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 829 817 ELSE ! leap frog 830 818 IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' 831 819 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 832 WHERE ( tmask(:,:,:) == 0.0_wp ) 820 WHERE ( tmask(:,:,:) == 0.0_wp ) 833 821 e3t(:,:,:,Kbb) = e3t_0(:,:,:) 834 822 END WHERE … … 854 842 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 855 843 ENDIF 856 ELSE 857 tilde_e3t_b(:,:,:) = 0.0_wp858 tilde_e3t_n(:,:,:) = 0.0_wp844 ELSE 845 tilde_e3t_b(:,:,:) = 0.0_wp 846 tilde_e3t_n(:,:,:) = 0.0_wp 859 847 ENDIF 860 848 ! ! ------------ ! … … 864 852 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 865 853 ELSE ! array is missing 866 hdiv_lf(:,:,:) = 0.0_wp 854 hdiv_lf(:,:,:) = 0.0_wp 867 855 ENDIF 868 856 ENDIF … … 885 873 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! 886 874 ! !=======================! 887 #if defined key_agrif888 IF ( .NOT.Agrif_root().AND.(ln_init_chfrpar) ) THEN889 ! Interpolate initial ssh from parent:890 CALL Agrif_istate_ssh( Kbb, Kmm )891 !892 DO jk = 1, jpk893 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 DO897 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)898 ENDIF899 #endif900 875 ! 901 876 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' … … 911 886 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 912 887 END IF 913 ! ! -------------! 888 ! ! -------------! 914 889 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 915 890 ! ! ------------ ! … … 925 900 !!--------------------------------------------------------------------- 926 901 !! *** ROUTINE dom_vvl_ctl *** 927 !! 902 !! 928 903 !! ** Purpose : Control the consistency between namelist options 929 904 !! for vertical coordinate … … 934 909 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 935 910 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 936 !!---------------------------------------------------------------------- 911 !!---------------------------------------------------------------------- 937 912 ! 938 913 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 28 28 # define gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t))) 29 29 # 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)) 30 47 #endif 31 48 !!---------------------------------------------------------------------- 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 142 142 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 143 143 INTEGER :: itile 144 INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n 144 145 REAL(wp):: zl, zi ! local scalars 145 146 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace … … 157 158 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 158 159 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 159 163 ! 160 164 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 161 165 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 172 173 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 ! 174 189 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 175 190 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 … … 197 212 ENDIF 198 213 ! 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 case200 214 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S 201 215 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points … … 233 247 ! 234 248 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 case236 249 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 237 250 ik = mbkt(ji,jj) -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DOM/istate.F90
r14086 r14200 90 90 91 91 #if defined key_agrif 92 IF ( (.NOT.Agrif_root()).AND.ln_init_chfrpar ) THEN92 IF ( .NOT.Agrif_root() .AND. ln_init_chfrpar ) THEN 93 93 numror = 0 ! define numror = 0 -> no restart file to read 94 94 ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) … … 97 97 ! 98 98 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 99 !!st100 !!st need for a recent agrif version to be displaced toward ssh_init_rst with agrif_istate_ssh101 ssh(:,:, Kmm) = ssh(:,: ,Kbb)102 !!st end103 99 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 104 100 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) … … 116 112 CALL day_init ! model calendar (using both namelist and restart infos) 117 113 ! ! Initialization of ocean to zero 114 ! 118 115 IF( ln_tsd_init ) THEN 119 116 CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 120 117 ! 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 123 119 vv (:,:,:,Kbb) = 0._wp 124 !125 IF( ll_wd ) THEN126 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD127 !128 ! Apply minimum wetdepth criterion129 !130 DO_2D( 1, 1, 1, 1 )131 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN132 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )133 ENDIF134 END_2D135 ENDIF136 120 ! 137 121 ELSE ! user defined initial T and S … … 142 126 ENDIF 143 127 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) 147 130 148 131 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynatf.F90
r14072 r14200 60 60 PUBLIC dyn_atf ! routine called by step.F90 61 61 62 #if defined key_qco 62 #if defined key_qco || defined key_linssh 63 63 !!---------------------------------------------------------------------- 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 65 67 !!---------------------------------------------------------------------- 66 68 CONTAINS 67 69 68 SUBROUTINE dyn_atf 70 SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 69 71 INTEGER , INTENT(in ) :: kt ! ocean time-step index 70 72 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 66 66 CONTAINS 67 67 68 SUBROUTINE dyn_atf_qco 68 SUBROUTINE dyn_atf_qco( kt, Kbb, Kmm, Kaa, puu, pvv ) 69 69 !!---------------------------------------------------------------------- 70 70 !! *** ROUTINE dyn_atf_qco *** … … 196 196 ! JC: Would be more clever to swap variables than to make a full vertical 197 197 ! 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 199 215 uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 200 216 uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) … … 211 227 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) 212 228 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) 229 #endif 213 230 ! 214 231 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 183 183 ENDIF 184 184 ! 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 190 192 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' ) 194 194 ENDIF 195 #endif 195 196 ! 196 197 ! ! Set nhpg from ln_hpg_... flags & consistency check … … 239 240 END IF 240 241 END IF 242 ! 241 243 END SUBROUTINE dyn_hpg_init 242 244 … … 756 758 ! 4. a) Upper half of top-most grid box, compute and store 757 759 !------------------------------------------------------------- 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) 759 761 DO_2D( 0, 1, 0, 1) 760 762 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 406 406 END SELECT 407 407 ! 408 #if defined key_qco 408 #if defined key_qco || defined key_linssh 409 409 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 410 410 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) … … 533 533 ! 534 534 ! 535 #if defined key_qco 535 #if defined key_qco || defined key_linssh 536 536 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 537 537 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) … … 624 624 ! ! =============== 625 625 ! 626 #if defined key_qco 626 #if defined key_qco || defined key_linssh 627 627 DO_2D( 1, 0, 1, 0 ) ! == reciprocal of e3 at F-point (key_qco) 628 628 z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) … … 952 952 ! 953 953 END SELECT 954 #if defined key_qco 955 SELECT CASE( nvor_scheme ) ! qco case: pre-computed a specific e3f_0 for some vorticity schemes954 #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 956 956 CASE( np_ENS , np_ENE , np_EEN , np_MIX ) 957 957 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/sshwzv.F90
r14053 r14200 18 18 !! ssh_atf : time filter the ssh arrays 19 19 !! wzv : compute now vertical velocity 20 !! ssh_init_rst : ssh set from restart or domcfg.nc file or usr_def_istat_ssh21 20 !!---------------------------------------------------------------------- 22 21 USE oce ! ocean dynamics and tracers variables … … 29 28 USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY 30 29 USE bdydyn2d ! bdy_ssh routine 30 USE wet_dry ! Wetting/Drying flux limiting 31 31 #if defined key_agrif 32 32 USE agrif_oce … … 41 41 USE lib_mpp ! MPP library 42 42 USE timing ! Timing 43 USE wet_dry ! Wetting/Drying flux limiting44 USE usrdef_istate, ONLY : usr_def_istate_ssh ! user defined ssh initial state45 43 46 44 IMPLICIT NONE … … 51 49 PUBLIC wAimp ! called by step.F90 52 50 PUBLIC ssh_atf ! called by step.F90 53 PUBLIC ssh_init_rst ! called by domain.F9054 51 55 52 !! * Substitutions … … 436 433 ! 437 434 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_def447 !! * ln_rstart = T448 !! USE of IOM library to read ssh in the restart file449 !! Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T450 !!451 !! * otherwise452 !! call user defined ssh or453 !! set to -ssh_ref in wet and drying case with domcfg.nc454 !!455 !! NB: ssh_b/n are written by restart.F90456 !!----------------------------------------------------------------------457 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices458 !459 INTEGER :: ji, jj, jk460 !!----------------------------------------------------------------------461 !462 IF(lwp) THEN463 WRITE(numout,*)464 WRITE(numout,*) 'ssh_init_rst : ssh initialization'465 WRITE(numout,*) '~~~~~~~~~~~~ '466 ENDIF467 !468 ! !=============================!469 IF( ln_rstart ) THEN !== Read the restart file ==!470 ! !=============================!471 !472 ! !* Read ssh at Kmm473 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-step478 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 Kbb483 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 ENDIF487 ! !============================!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 dry495 !496 IF( ln_read_cfg ) THEN ! read configuration : ssh_ref is read in domain_cfg file497 !!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 Kmm499 ssh(:,:,Kbb) = -ssh_ref500 !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 depth503 ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj)504 ENDIF505 END_2D506 ELSE ! user define configuration case507 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) )508 ENDIF509 !510 ELSE !* user defined configuration511 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) )512 !513 ENDIF514 !515 ssh(:,:,Kmm) = ssh(:,:,Kbb) !* set now values from to before ones516 ssh(:,:,Kaa) = 0._wp517 ENDIF518 !519 END SUBROUTINE ssh_init_rst520 435 521 436 !!====================================================================== -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ICB/icbutl.F90
r14030 r14200 57 57 PUBLIC icb_utl_heat ! routine called in icbdia module 58 58 59 !! * Substitutions 60 # include "domzgr_substitute.h90" 59 61 !!---------------------------------------------------------------------- 60 62 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 127 129 CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) 128 130 voce_e(:,:,jk) = ztmp(:,:) 131 ! 132 e3t_e(1:jpi,1:jpj,jk) = e3t(:,:,jk,Kmm) 129 133 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) 132 135 END IF 133 136 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/IOM/restart.F90
r14072 r14200 11 11 !! 3.7 ! 2014-01 (G. Madec) suppression of curl and hdiv from the restart 12 12 !! - ! 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 14 15 !!---------------------------------------------------------------------- 15 16 16 17 !!---------------------------------------------------------------------- 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 20 23 !!---------------------------------------------------------------------- 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 ! ??? 27 33 ! 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 32 37 33 38 IMPLICIT NONE 34 39 PRIVATE 35 40 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" 41 50 !!---------------------------------------------------------------------- 42 51 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 142 151 !! 143 152 !! NB: ssh is written here (rst_write) 144 !! but is read or set in DYN/sshwzv:shh_init_rst153 !! but is read or set in rst_read_ssh 145 154 !!---------------------------------------------------------------------- 146 155 INTEGER, INTENT(in) :: kt ! ocean time-step 147 156 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 148 157 !!---------------------------------------------------------------------- 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 ) 168 185 IF( kt == nitrst ) THEN 169 IF( .NOT.lwxios) THEN186 IF( .NOT.lwxios ) THEN 170 187 CALL iom_close( numrow ) ! close the restart file (only at last time step) 171 188 ELSE … … 177 194 !!gm not sure what to do here ===>>> ask to Sebastian 178 195 lrst_oce = .FALSE. 179 180 181 nitrst= nn_stocklist( nrst_lst )182 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 183 200 ENDIF 184 201 ! … … 245 262 !! (sshb) 246 263 !! 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 251 267 INTEGER :: jk 252 268 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 256 273 ! 257 274 ! !* Diurnal DSST 258 275 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 259 IF 276 IF( ln_diurnal_only ) THEN 260 277 IF(lwp) WRITE( numout, * ) & 261 278 & "rst_read:- ln_diurnal_only set, setting rhop=rho0" … … 266 283 ENDIF 267 284 ! 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) 269 296 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) 276 305 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 279 307 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) 281 311 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 292 336 ENDIF 293 337 ! 294 338 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 295 438 296 439 !!===================================================================== -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ISF/isfcpl.F90
r14072 r14200 15 15 #if defined key_qco 16 16 USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation 17 #elif defined key_linssh 18 ! ! fix in time coordinate 17 19 #else 18 20 USE domvvl , ONLY : dom_vvl_zgr ! vertical scale factor interpolation … … 117 119 vv (:,:,:,Kbb) = vv (:,:,:,Kmm) 118 120 ssh (:,:,Kbb) = ssh (:,:,Kmm) 119 #if ! defined key_qco 121 #if ! defined key_qco && ! defined key_linssh 120 122 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 121 123 #endif … … 217 219 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 218 220 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 220 226 DO jk = 1, jpk 221 227 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) … … 223 229 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 224 230 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 225 #else226 CALL dom_qco_zgr(Kbb, Kmm)227 231 #endif 228 232 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ISF/isfstp.F90
r14064 r14200 87 87 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 88 88 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 ) 90 90 #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 ) 92 92 #endif 93 93 ! … … 116 116 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 117 117 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 ) 119 119 #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 ) 121 121 #endif 122 122 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/LDF/ldfc1d_c2d.F90
r14072 r14200 140 140 END_2D 141 141 CASE( 'TRA' ) ! U- and V-points 142 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk143 142 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 144 143 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 427 427 zaht_min = 0.2_wp * aht0 ! minimum value for aht 428 428 zDaht = aht0 - zaht_min 429 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk430 429 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 431 430 !!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 24 24 ! 25 25 USE in_out_manager ! I/O manager 26 USE iom ! IOM 26 27 USE lib_mpp ! distribued memory computing library 27 28 USE timing ! Timing … … 34 35 PUBLIC sbc_fwb ! routine called by step 35 36 36 REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget37 REAL(wp) :: a_fwb ! for 2 year before (_b) and before year.38 REAL(wp) :: fwfold ! fwfold to be suppressed37 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 39 40 REAL(wp) :: area ! global mean ocean surface (interior domain) 40 41 … … 65 66 INTEGER, INTENT( in ) :: Kmm ! ocean time level index 66 67 ! 67 INTEGER :: i num, ikty, iyear! local integers68 INTEGER :: ios, inum, ikty ! local integers 68 69 REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars 69 70 REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - … … 72 73 REAL(wp) ,DIMENSION(1) :: z_fwfprv 73 74 COMPLEX(dp),DIMENSION(1) :: y_fwfnow 75 ! 76 NAMELIST/namsbc_fwb/rn_fwb0 74 77 !!---------------------------------------------------------------------- 75 78 ! 76 79 IF( kt == nit000 ) THEN 80 READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 ) 81 901 IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist' ) 82 READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) 83 902 IF( ios > 0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' ) 84 IF(lwm) WRITE( numond, namsbc_fwb ) 77 85 IF(lwp) THEN 78 86 WRITE(numout,*) … … 80 88 WRITE(numout,*) '~~~~~~~' 81 89 IF( kn_fwb == 1 ) WRITE(numout,*) ' instantaneously set to zero' 82 IF( kn_fwb == 2 ) WRITE(numout,*) ' adjusted from previous year budget'83 90 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 84 97 ENDIF 85 98 ! … … 112 125 ENDIF 113 126 ! 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 ! 123 138 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 ! 127 141 ENDIF 128 ! ! Update fwfoldif new year start142 ! ! Update a_fwb if new year start 129 143 ikty = 365 * 86400 / rn_Dt !!bug use of 365 days leap year or 360d year !!!!!!! 130 144 IF( MOD( kt, ikty ) == 0 ) THEN 131 a_fwb_b = a_fwb! mean sea level taking into account the ice+snow145 ! mean sea level taking into account the ice+snow 132 146 ! sum over the global domain 133 147 a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) 134 148 a_fwb = a_fwb * 1.e+3 / ( area * rday * 365. ) ! convert in Kg/m3/s = mm/s 135 149 !!gm ! !!bug 365d year 136 fwfold = a_fwb ! current year freshwater budget correction137 ! ! estimate from the previous year budget138 150 ENDIF 139 151 ! 140 152 IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes 141 zcoef = fwfold* rcp142 emp(:,:) = emp(:,:) + fwfold* tmask(:,:,1)153 zcoef = a_fwb * rcp 154 emp(:,:) = emp(:,:) + a_fwb * tmask(:,:,1) 143 155 qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 144 156 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' 151 166 ! 152 167 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 89 89 90 90 ! !!! 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. 93 93 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 94 94 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 175 175 ENDIF 176 176 ! 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)178 177 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 179 178 ! … … 194 193 END IF 195 194 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_zco197 195 IF (nn_hls.EQ.2) THEN 198 196 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 82 82 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 83 83 ! 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 reverted85 84 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 86 85 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 102 101 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 103 102 ENDIF 104 ! NOTE: [tiling-comms-merge] Bug fix- move array zeroing out of this IF block105 103 ! 106 104 l_trd = .FALSE. ! set local switches … … 353 351 END_3D 354 352 END IF 355 ! NOTE: [tiling-comms-merge] I tested this356 ! NOT TESTED - NEED l_trd OR l_hst TRUE357 353 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 358 354 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes … … 369 365 ! 370 366 ENDIF 371 ! NOTE: [tiling-comms-merge] I tested this372 ! NOT TESTED - NEED l_ptr TRUE373 367 IF( l_ptr ) THEN ! "Poleward" transports 374 368 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 92 92 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 93 93 ! 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 reverted95 94 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components 96 95 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 141 141 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 142 142 ! lateral boundary conditions ; just need for outputs 143 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed144 143 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 145 144 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport … … 249 248 DO jn = 1, kjpt ! tracer loop 250 249 ! ! =========== 251 ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices252 250 DO_2D( isj, 0, isi, 0 ) ! CAUTION start from i=1 to update i=2 when cyclic east-west 253 251 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 92 92 CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 93 93 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 step95 94 IF(nn_hls.EQ.2) CALL lbc_lnk( 'tra_ldf', pts(:,:,:,:,Kbb), 'T',1.) 96 95 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 158 158 ENDIF 159 159 ! 160 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling161 160 DO_3D( isj, iej, isi, iei, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 162 161 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & … … 236 235 END SELECT 237 236 ! 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 why239 237 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign) 240 238 ! ! 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 112 112 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 113 113 ! 114 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling115 114 DO_2D( isj, iej, isi, iei ) ! interior column only 116 115 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/TRA/traqsr.F90
r14090 r14200 137 137 ! ! before qsr induced heat content ! 138 138 ! !-----------------------------------! 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_atf140 139 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 141 140 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 98 98 ENDIF 99 99 ! 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_atf101 100 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 102 101 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF … … 155 154 ! 156 155 DO jn = 1, jpts !== update tracer trend ==! 157 ! NOTE: [tiling-comms-merge] This looped over nn_hls, which changes the results when using tiling158 156 DO_2D( 0, 0, 0, 0 ) 159 157 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 23 23 USE trd_oce ! trends: ocean variables 24 24 USE trdtra ! trends: tracer trend manager 25 USE eosbn2, ONLY: ln_SEOS, rn_b0 25 26 ! 26 27 USE in_out_manager ! I/O manager … … 83 84 ! JMM avoid negative salinities near river outlet ! Ugly fix 84 85 ! 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 86 90 !!gm 87 91 … … 97 101 & - ztrds(:,:,jk) 98 102 END DO 99 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed100 103 !!gm this should be moved in trdtra.F90 and done on all trends 101 104 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 124 124 ! 125 125 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.127 126 IF (nn_hls.EQ.2) THEN 128 127 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 91 91 IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays 92 92 IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) 93 avt_evd(:,:,:) = 0._wp 93 94 ENDIF 94 95 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/ZDF/zdfgls.F90
r14072 r14200 187 187 IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) 188 188 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) 191 191 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 & 192 192 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) … … 194 194 IF( ln_isfcav ) THEN 195 195 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) 198 198 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 & 199 199 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) … … 396 396 zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 397 397 zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp 398 en (ji,jj,ibot) = z_en 398 399 END_2D 399 400 IF( ln_isfcav) THEN ! top boundary (ocean cavity) … … 410 411 zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 411 412 zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp 413 en (ji,jj,itop) = z_en 412 414 END_2D 413 415 ENDIF -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/nemogcm.F90
r14086 r14200 51 51 USE istate ! initial state setting (istate_init routine) 52 52 USE trdini ! dyn/tra trends initialization (trd_init routine) 53 USE asminc ! assimilation increments54 USE asmbkg ! writing out state trajectory55 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 analysis59 #if defined key_qco60 USE stepMLF ! NEMO time-stepping (stp_MLF routine)61 #else62 USE step ! NEMO time-stepping (stp routine)63 #endif64 USE isfstp ! ice shelf (isf_stp_init routine)65 53 USE icbini ! handle bergs, initialisation 66 54 USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files … … 78 66 USE ice_domain_size, only: nx_global, ny_global 79 67 #endif 80 #if defined key_qco 68 #if defined key_qco || defined key_linssh 81 69 USE stpmlf ! NEMO time-stepping (stp_MLF routine) 82 70 #else … … 88 76 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 89 77 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 98 79 99 80 IMPLICIT NONE … … 180 161 ! 181 162 DO WHILE( istp <= nitend .AND. nstop == 0 ) 182 # if defined key_qco 163 ! 164 # if defined key_qco || defined key_linssh 183 165 CALL stp_MLF 184 166 # else … … 201 183 ENDIF 202 184 ! 203 # if defined key_qco 204 CALL stp_MLF 185 # if defined key_qco || defined key_linssh 186 CALL stp_MLF( istp ) 205 187 # else 206 CALL stp 188 CALL stp ( istp ) 207 189 # endif 208 190 istp = istp + 1 … … 348 330 IF(lwp) THEN ! open listing units 349 331 ! 350 IF( .NOT. lwm ) & ! alreay opened for narea == 1332 IF( .NOT. lwm ) & ! alreay opened for narea == 1 351 333 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 352 334 ! -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/step.F90
r14072 r14200 33 33 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme 34 34 !!---------------------------------------------------------------------- 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 38 40 !!---------------------------------------------------------------------- 39 41 #else -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/step_oce.F90
r14090 r14200 110 110 USE agrif_oce_sponge ! Momemtum and tracers sponges 111 111 USE agrif_all_update ! Main update driver 112 USE agrif_oce_update 112 113 #endif 113 114 #if defined key_top -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/stpctl.F90
r14053 r14200 15 15 !!---------------------------------------------------------------------- 16 16 !! stp_ctl : Control the run 17 !! stp_ctl_SWE : Control the run (SWE only) 17 18 !!---------------------------------------------------------------------- 18 19 USE oce ! ocean dynamics and tracers variables … … 26 27 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 28 USE lib_mpp ! distributed memory computing 29 USE eosbn2, ONLY: ln_SEOS, rn_b0 30 ! 28 31 USE netcdf ! NetCDF library 29 30 32 IMPLICIT NONE 31 33 PRIVATE 32 34 33 35 PUBLIC stp_ctl ! routine called by step.F90 36 PUBLIC stp_ctl_SWE ! routine called by stpmlf.F90 34 37 35 38 INTEGER :: nrunid ! netcdf file id 36 39 INTEGER, DIMENSION(8) :: nvarid ! netcdf variable id 40 INTEGER, DIMENSION(2) :: nvarid_SWE ! netcdf variable id (SWE only) 37 41 !!---------------------------------------------------------------------- 38 42 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 65 69 INTEGER , DIMENSION(9) :: iareasum, iareamin, iareamax 66 70 INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices 67 REAL(wp) :: zzz 71 REAL(wp) :: zzz, zminsal, zmaxsal ! local real 68 72 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal 69 73 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce … … 71 75 CHARACTER(len=20) :: clname 72 76 !!---------------------------------------------------------------------- 73 !74 77 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 75 78 ! … … 180 183 END DO 181 184 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 182 END IF185 END IF 183 186 ! !== error handling ==! 184 187 ! !== done by all processes at every time step ==! 185 188 ! 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 ! 186 197 IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m ) 187 198 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 188 & zmax(3) <= 0._wp.OR. & ! negative or zero sea surface salinity189 & 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) 191 202 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests 192 203 & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests … … 262 273 263 274 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 ! 447 9500 FORMAT(' it :', i8, ' e3t_min: ', D23.16, ' |U|_max: ', D23.16) 448 ! 449 END SUBROUTINE stp_ctl_SWE 450 451 264 452 SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 265 453 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/stpmlf.F90
r14053 r14200 36 36 !!---------------------------------------------------------------------- 37 37 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 45 47 !!---------------------------------------------------------------------- 46 48 USE step_oce ! time stepping definition modules … … 196 198 END DO 197 199 CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) 198 IF( .NOT.l n_linssh ) THEN200 IF( .NOT.lk_linssh ) THEN 199 201 CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa) ) ! "after" ssh/h_0 ratio at t,u,v pts 200 202 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 … … 225 227 IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated 226 228 CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case) 227 IF(.NOT.l n_linssh) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! update ssh/h_0 ratio at t,u,v,f pts229 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 228 230 ENDIF 229 231 CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion … … 257 259 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 258 260 CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height 259 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 260 262 #if defined key_top 261 263 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 311 313 CALL finalize_lbc ( kstp, Nbb , Naa, uu, vv, ts ) ! boundary conditions 312 314 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 314 317 r3t(:,:,Nnn) = r3t_f(:,:) ! update now ssh/h_0 with time filtered values 315 318 r3u(:,:,Nnn) = r3u_f(:,:) 316 319 r3v(:,:,Nnn) = r3v_f(:,:) 320 ENDIF 317 321 318 322 ! … … 367 371 IF( kstp == nitend .OR. indic < 0 ) THEN 368 372 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 369 IF( lrxios ) CALL iom_context_finalize( crxios_context )370 373 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 371 374 ENDIF -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/nemogcm.F90
r14053 r14200 33 33 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 34 34 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 35 USE halo_mng ! Halo manager35 USE halo_mng ! halo manager 36 36 37 37 IMPLICIT NONE … … 127 127 IF( nstop /= 0 .AND. lwp ) THEN ! error print 128 128 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 ) 130 131 ENDIF 131 132 ! … … 216 217 WRITE(numout,*) ' NEMO team' 217 218 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,*) ' ======================' 219 223 WRITE(numout,*) 220 224 WRITE(numout,*) " ._ ._ ._ ._ ._ " … … 232 236 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 233 237 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" 240 245 ENDIF 241 WRITE(numout,*) 242 ! 243 WRITE(numout,cform_aaa) ! Flag AAAAAAA 246 WRITE(numout,*) "~~~~~~~~ ****************" 247 WRITE(numout,*) 244 248 ! 245 249 ENDIF … … 280 284 ! !-------------------------------! 281 285 282 CALL nemo_ctl ! Control prints 286 CALL nemo_ctl ! Control prints of namctl and namcfg 283 287 ! 284 288 ! ! General initialization … … 429 433 END SUBROUTINE nemo_alloc 430 434 431 435 432 436 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 433 437 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/stp_oce.F90
r14053 r14200 93 93 ! (dyn_asm_inc routine) 94 94 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) 96 96 USE restart ! ocean restart (rst_wri routine) 97 97 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 70 70 ENDIF 71 71 72 IF( kstp == nit000 ) ww(:,:,:) = 0._wp ! initialize vertical velocity on e for all to zero72 IF( kstp == nit000 ) ww(:,:,:) = 0._wp ! initialize vertical velocity once for all to zero 73 73 74 74 ! … … 222 222 ! Control 223 223 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 224 CALL stp_ctl 224 CALL stp_ctl_SWE ( kstp, Nnn ) 225 225 226 226 IF( kstp == nit000 ) THEN ! 1st time step only … … 235 235 !!st : cxios_context needed ? because opened earlier ??? 236 236 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 )239 237 ENDIF 240 238 #endif -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/SWE/stprk3.F90
r14053 r14200 129 129 CALL dyn_ldf( kstp, Nbb, Nbb, uu, vv, Nrhs ) ! lateral mixing 130 130 #endif 131 !!st !132 !!st DO_3D( 0,0, 0,0, 1,jpkm1 )133 !!st ! ! horizontal pressure gradient134 !!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_3D137 !!st !138 !!st #if defined key_RK3all139 !!st ! ! wind stress and layer friction140 !!st z5_6 = 5._wp/6._wp141 !!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_3D147 !!st #endif148 !!st why not ?149 131 z5_6 = 5._wp/6._wp 150 132 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) … … 163 145 vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + zrhs_v 164 146 END_3D 165 !!st end166 147 ! 167 148 ! !== Time stepping of ssh Eq. ==! (and update r3_Naa) … … 229 210 vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + zrhs_v 230 211 END_3D 231 !!st !232 !!st DO_3D( 0, 0, 0, 0, 1, jpkm1 )233 !!st ! ! horizontal pressure gradient234 !!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_3D237 !!st !238 !!st #if defined key_RK3all239 !!st ! ! wind stress and layer friction240 !!st z3_4 = 3._wp/4._wp241 !!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_3D247 !!st #endif248 212 ! 249 213 ! !== Time stepping of ssh Eq. ==! (and update r3_Naa) … … 344 308 345 309 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 346 ! diagnostics and outputs 310 ! diagnostics and outputs at Nbb (i.e. the just computed time step) 347 311 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 348 312 349 IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn) ! Courant number diagnostics350 CALL dia_wri ( kstp, Nnn) ! ocean model: outputs351 ! 352 IF( lrst_oce ) CALL rst_write ( kstp, Nbb, N nn) ! write output ocean restart file313 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 353 317 354 318 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 355 319 ! Control 356 320 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 357 CALL stp_ctl ( kstp, Nnn)321 CALL stp_ctl_SWE ( kstp , Nbb ) 358 322 359 323 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 56 56 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 57 57 58 IF( l_1st_euler .OR. ln_top_euler ) THEN 59 tr(:,:,:,jp_age,Kbb) = tr(:,:,:,jp_age,Kmm) 60 ENDIF 61 58 62 59 63 DO jk = 1, nla_age -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/TOP/TRP/trcatf.F90
r14086 r14200 25 25 !! 'key_top' TOP models 26 26 !!---------------------------------------------------------------------- 27 !! trc_atf : time stepping on passive tracers27 !! trc_atf : time stepping on passive tracers 28 28 !!---------------------------------------------------------------------- 29 29 USE par_trc ! need jptra, number of passive tracers 30 USE oce_trc 31 USE trc 30 USE oce_trc ! ocean dynamics and tracers variables 31 USE trc ! ocean passive tracers variables 32 32 USE trd_oce 33 33 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) 36 36 # else 37 USE traatf 37 USE traatf ! tracer : Asselin filter (vvl) 38 38 # endif 39 39 USE bdy_oce , ONLY: ln_bdy 40 USE trcbdy 40 USE trcbdy ! BDY open boundaries 41 41 # if defined key_agrif 42 42 USE agrif_top_interp 43 43 # endif 44 44 ! 45 USE lbclnk 46 USE prtctl 45 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 46 USE prtctl ! Print control for debbuging 47 47 48 48 IMPLICIT NONE … … 103 103 #endif 104 104 ! 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 ) 106 106 107 107 IF( ln_bdy ) CALL trc_bdy( kt, Kbb, Kmm, Kaa ) … … 157 157 ELSE 158 158 IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping 159 # if defined key_qco 159 # if defined key_qco || defined key_linssh 160 160 IF( ln_linssh ) THEN ; CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh 161 161 ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 162 162 # else 163 IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh164 ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh163 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 165 165 # endif 166 166 ENDIF … … 169 169 ENDIF 170 170 ! 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 ) 172 172 ENDIF 173 173 ! … … 193 193 END SUBROUTINE trc_atf 194 194 195 # if ! defined key_qco195 # if defined key_qco || defined key_linssh 196 196 SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 197 197 !!---------------------------------------------------------------------- … … 225 225 INTEGER :: ji, jj, jk, jn ! dummy loop indices 226 226 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 ! - - 228 228 !!---------------------------------------------------------------------- 229 229 ! … … 241 241 DO jn = 1, jptra 242 242 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) 246 246 ! ! tracer content at Before, now and after 247 ztc_b = ptr(ji,jj,jk,jn,Kbb) 248 ztc_n = ptr(ji,jj,jk,jn,Kmm) 247 ztc_b = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 248 ztc_n = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 249 249 ztc_a = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 250 250 ! 251 ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b252 251 ztc_d = ztc_a - 2. * ztc_n + ztc_b 253 252 ! 254 ze3t_f = ze3t_n + rn_atfp * ze3t_d253 ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk) 255 254 ztc_f = ztc_n + rn_atfp * ztc_d 256 255 ! 257 256 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) )259 257 ztc_f = ztc_f - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 260 258 ENDIF … … 300 298 INTEGER :: ji, jj, jk, jn ! dummy loop indices 301 299 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 ! - - 303 301 !!---------------------------------------------------------------------- 304 302 ! … … 316 314 DO jn = 1, jptra 317 315 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) 321 319 ! ! tracer content at Before, now and after 322 ztc_b = ptr(ji,jj,jk,jn,Kbb) * ze3t_b323 ztc_n = ptr(ji,jj,jk,jn,Kmm) * ze3t_n320 ztc_b = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 321 ztc_n = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 324 322 ztc_a = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 325 323 ! 324 ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 326 325 ztc_d = ztc_a - 2. * ztc_n + ztc_b 327 326 ! 328 ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk)327 ze3t_f = ze3t_n + rn_atfp * ze3t_d 329 328 ztc_f = ztc_n + rn_atfp * ztc_d 330 329 ! 331 330 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) ) 332 332 ztc_f = ztc_f - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 333 333 ENDIF -
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/TOP/trcais.F90
r14032 r14200 38 38 !! * Substitutions 39 39 # include "do_loop_substitute.h90" 40 # include "domzgr_substitute.h90" 40 41 !!---------------------------------------------------------------------- 41 42 !! 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_iomput1 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 16 16 USE dom_oce 17 17 USE phycst ! physical constants 18 USE eosbn2, ONLY: rn_a0 18 19 ! 19 20 USE in_out_manager ! I/O manager … … 197 198 zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 198 199 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) 201 202 END DO 202 203 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 1 bld::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 15 15 USE par_oce ! ocean space and time domain 16 16 USE phycst ! physical constants 17 USE eosbn2, ONLY: rn_a0 17 18 ! 18 19 USE in_out_manager ! I/O manager … … 23 24 24 25 PUBLIC usr_def_istate ! called by istate.F90 25 26 PUBlIC usr_def_istate_ssh 26 27 !!---------------------------------------------------------------------- 27 28 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 34 35 CONTAINS 35 36 36 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 37 38 !!---------------------------------------------------------------------- 38 39 !! *** ROUTINE usr_def_istate *** … … 54 55 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 55 56 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 height57 57 ! 58 58 INTEGER :: ji,jj,jk ! dummy loop indices … … 70 70 pu (:,:,:) = 0._wp ! ocean at rest 71 71 pv (:,:,:) = 0._wp 72 pssh(:,:) = 0._wp73 72 pts(:,:,:,:) = 0._wp 74 73 ! … … 100 99 zf = 1._wp 101 100 ENDIF 102 zrho1 = rho0*zn2*zdt/grav/ 0.2_wp101 zrho1 = rho0*zn2*zdt/grav/rn_a0 103 102 pts(ji,jj,jk,jp_tem) = (15._wp - zrho1) * ptmask(ji,jj,jk) 104 103 ! 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)**2106 ! ztu = 15._wp*gdepw_0(ji,jj,jk )-0.5*rho0*zn2/(0.2_wp*grav)*gdepw_0(ji,jj,jk )**2107 !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) 108 107 IF (Agrif_root().AND.( mjg0(jj) == Nj0glo-2 ) ) THEN 109 108 pv(ji,jj,jk) = -sqrt(zdb*zh0)*exp(-zxw/zro)*(1._wp-zf) * ptmask(ji,jj,jk) 110 109 ENDIF 111 110 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) 113 112 pts(ji,jj,jk,jp_sal) = 1._wp * ptmask(ji,jj,jk) 114 113 ENDIF … … 118 117 END SUBROUTINE usr_def_istate 119 118 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 120 139 !!====================================================================== 121 140 END 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 1 bld::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_iomput1 bld::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_iomput1 bld::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 6 6 !! History : - ! 2007-03 (M.A. Morales Maqueda, S. Bouillon) Original code 7 7 !! 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 9 9 !! 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 11 11 !! 3.5 ! 2012-08 (R. Benshila) AGRIF 12 12 !! 3.6 ! 2016-06 (C. Rousset) Rewriting + landfast ice + mEVP (Bouillon 2013) … … 14 14 !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] 15 15 !! ! 2019 (S. Rynders, Y. Aksenov, C. Rousset) change into eap rheology from 16 !! CICE code (Tsamados, Heorton) 16 !! CICE code (Tsamados, Heorton) 17 17 !!---------------------------------------------------------------------- 18 18 #if defined key_si3 … … 30 30 USE icevar ! ice_var_sshdyn 31 31 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 34 34 #if defined key_agrif 35 35 USE agrif_ice_interp … … 66 66 INTEGER :: ncvgid ! netcdf file id 67 67 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 69 70 !!---------------------------------------------------------------------- 70 71 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 80 81 !! 81 82 !! ** 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 . 85 86 !! 86 87 !! The points in the C-grid look like this, dear reader … … 90 91 !! | 91 92 !! (ji-1,jj) | (ji,jj) 92 !! --------- 93 !! --------- 93 94 !! | | 94 95 !! | (ji,jj) |------(ji,jj) 95 96 !! | | 96 !! --------- 97 !! --------- 97 98 !! (ji-1,jj-1) (ji,jj-1) 98 99 !! … … 101 102 !! snow total volume (vt_s) per unit area 102 103 !! 103 !! ** Action : - compute u_ice, v_ice : the components of the 104 !! ** Action : - compute u_ice, v_ice : the components of the 104 105 !! sea-ice velocity vector 105 106 !! - compute delta_i, shear_i, divu_i, which are inputs … … 107 108 !! 108 109 !! ** Steps : 0) compute mask at F point 109 !! 1) Compute ice snow mass, ice strength 110 !! 1) Compute ice snow mass, ice strength 110 111 !! 2) Compute wind, oceanic stresses, mass terms and 111 112 !! coriolis terms of the momentum equation … … 166 167 REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points 167 168 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 169 170 ! 170 171 REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear … … 172 173 REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope: 173 174 ! ! 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 175 176 REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses 176 177 REAL(wp), DIMENSION(jpi,jpj) :: zspgU, zspgV ! surface pressure gradient at U/V points … … 192 193 !! --- diags 193 194 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 195 196 !! --- SIMIP diags 196 197 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s) … … 199 200 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_ymtrp_snw ! Y-component of snow mass transport (kg/s) 200 201 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) 202 203 !!------------------------------------------------------------------- 203 204 204 205 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_eap: EAP sea-ice rheology' 205 206 ! 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 ! 208 215 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 211 217 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 212 223 ! 213 224 !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... … … 249 260 ! 1) define some variables and initialize arrays 250 261 !------------------------------------------------------------------------------! 251 zrhoco = rho0 * rn_cio 262 zrhoco = rho0 * rn_cio 252 263 !extra code for test case boundary conditions 253 264 zinvw=1._wp/(zrhoco*0.5_wp) … … 270 281 ENDIF 271 282 z1_dtevp = 1._wp / zdtevp 272 273 ! Initialise stress tensor 274 zs1 (:,:) = pstress1_i (:,:) 283 284 ! Initialise stress tensor 285 zs1 (:,:) = pstress1_i (:,:) 275 286 zs2 (:,:) = pstress2_i (:,:) 276 287 zs12(:,:) = pstress12_i(:,:) … … 319 330 ! dt/m at T points (for alpha and beta coefficients) 320 331 zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) 321 332 322 333 ! m/dt 323 334 zmU_t(ji,jj) = zmassU * z1_dtevp 324 335 zmV_t(ji,jj) = zmassV * z1_dtevp 325 336 326 337 ! Drag ice-atm. 327 338 ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) … … 353 364 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) 354 365 ! 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 356 367 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 357 368 ! 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 359 370 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 360 371 ! 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 362 373 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 363 374 END_2D … … 377 388 ! ! ==================== ! 378 389 DO jter = 1 , nn_nevp ! loop over jter ! 379 ! ! ==================== ! 390 ! ! ==================== ! 380 391 l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1 381 392 ! … … 404 415 & + 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) & 405 416 & ) * 0.25_wp * r1_e1e2t(ji,jj) 406 417 407 418 ! divergence at T points 408 419 zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & … … 410 421 & ) * r1_e1e2t(ji,jj) 411 422 zdiv2 = zdiv * zdiv 412 423 413 424 ! tension at T points 414 425 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) & … … 418 429 419 430 ! delta at T points 420 zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 431 zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 421 432 422 433 END_2D 423 434 CALL lbc_lnk( 'icedyn_rhg_eap', zdelta, 'T', 1.0_wp ) 424 435 425 436 ! P/delta at T points 426 437 DO_2D( 1, 1, 1, 1 ) … … 430 441 DO_2D( 0, 1, 0, 1 ) ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 431 442 432 ! shear at T points 443 ! shear at T points 433 444 zdsT = ( zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * e1e2f(ji-1,jj ) & 434 445 & + zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & 435 446 & ) * 0.25_wp * r1_e1e2t(ji,jj) 436 447 437 448 ! divergence at T points (duplication to avoid communications) 438 449 zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 439 450 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 440 451 & ) * r1_e1e2t(ji,jj) 441 452 442 453 ! tension at T points (duplication to avoid communications) 443 454 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) & … … 459 470 zyield22(ji,jj) = 0.5_wp * (zstressptmp - zstressmtmp) 460 471 zyield12(ji,jj) = zstress12tmp(ji,jj) 461 prdg_conv(ji,jj) = -min( zalphar, 0._wp) 472 prdg_conv(ji,jj) = -min( zalphar, 0._wp) 462 473 ENDIF 463 474 … … 491 502 492 503 DO_2D( 1, 0, 1, 0 ) 493 ! stress12tmp at F points 504 ! stress12tmp at F points 494 505 zstress12tmpF = ( zstress12tmp(ji,jj+1) * e1e2t(ji,jj+1) + zstress12tmp(ji+1,jj+1) * e1e2t(ji+1,jj+1) & 495 506 & + zstress12tmp(ji,jj ) * e1e2t(ji,jj ) + zstress12tmp(ji+1,jj ) * e1e2t(ji+1,jj ) & … … 504 515 ! zalph2 = zalph2 - 1._wp 505 516 ENDIF 506 517 507 518 ! stress at F points (zkt/=0 if landfast) 508 519 zs12(ji,jj) = ( zs12(ji,jj) * zalph1 + zstress12tmpF ) * z1_alph1 … … 570 581 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 571 582 & ) / 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) & 573 584 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 574 585 & ) / ( zbetav + 1._wp ) & … … 630 641 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 631 642 & ) / ( 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 633 644 & ) * zmsk00x(ji,jj) 634 645 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) … … 637 648 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 638 649 & + ( 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 640 651 & ) * zmsk00x(ji,jj) 641 652 ENDIF … … 689 700 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 690 701 & ) / ( 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 692 703 & ) * zmsk00x(ji,jj) 693 704 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) … … 744 755 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 745 756 & + 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 ) & 747 758 & ) * 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 748 759 & ) * zmsk00y(ji,jj) … … 771 782 772 783 ! 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 ) 774 785 ! 775 786 ! ! ==================== ! … … 781 792 ! 782 793 !------------------------------------------------------------------------------! 783 ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) 794 ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) 784 795 !------------------------------------------------------------------------------! 785 796 DO_2D( 1, 0, 1, 0 ) … … 791 802 792 803 END_2D 793 804 794 805 DO_2D( 0, 0, 0, 0 ) 795 806 796 807 ! tension**2 at T points 797 808 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) & … … 799 810 & ) * r1_e1e2t(ji,jj) 800 811 zdt2 = zdt * zdt 801 812 802 813 zten_i(ji,jj) = zdt 803 814 … … 806 817 & + 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) & 807 818 & ) * 0.25_wp * r1_e1e2t(ji,jj) 808 819 809 820 ! shear at T points 810 821 pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) … … 814 825 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 815 826 & ) * r1_e1e2t(ji,jj) 816 827 817 828 ! 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 819 830 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0 820 831 pdelta_i(ji,jj) = zfac + rn_creepl * rswitch ! delta+creepl … … 824 835 & zten_i, 'T', 1.0_wp, zs1 , 'T', 1.0_wp, zs2 , 'T', 1.0_wp, & 825 836 & zs12, 'F', 1.0_wp ) 826 837 827 838 ! --- Store the stress tensor for the next time step --- ! 828 839 pstress1_i (:,:) = zs1 (:,:) … … 841 852 & ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 842 853 ! 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 851 862 ! --- divergence, shear and strength --- ! 852 IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence853 IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear854 IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , pdelta_i * zmsk00 ) ! delta855 IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength863 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 856 867 857 868 ! --- Stress tensor invariants (SIMIP diags) --- ! … … 859 870 ! 860 871 ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) 861 ! 872 ! 862 873 DO_2D( 1, 1, 1, 1 ) 863 874 864 875 ! Ice stresses 865 876 ! sigma1, sigma2, sigma12 are some useful recombination of the stresses (Hunke and Dukowicz MWR 2002, Bouillon et al., OM2013) 866 877 ! These are NOT stress tensor components, neither stress invariants, neither stress principal components 867 878 ! 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 ) 869 880 zsig1 = zfac * ( pdivu_i(ji,jj) - pdelta_i(ji,jj) ) 870 881 zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) 871 882 zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) 872 883 873 884 ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008) 874 885 zsig_I (ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure 875 886 zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress 876 887 877 888 END_2D 878 889 ! 879 890 ! 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 stress881 IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress882 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 883 894 DEALLOCATE ( zsig_I, zsig_II ) 884 895 885 896 ENDIF 886 897 … … 891 902 IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN 892 903 ! 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 ! 895 906 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 898 909 ! and **deformations** at current iterates 899 910 ! following Lemieux & Dupont (2020) … … 902 913 zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) 903 914 zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) 904 915 905 916 ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008), T-point 906 917 zsig_I(ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure 907 918 zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress 908 919 909 920 ! Normalized principal stresses (used to display the ellipse) 910 921 z1_strength = 1._wp / MAX( 1._wp, strength(ji,jj) ) … … 913 924 END_2D 914 925 ! 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 918 929 DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II ) 919 930 920 931 ENDIF 921 932 … … 925 936 CALL lbc_lnk_multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 926 937 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 ) 930 941 ENDIF 931 942 932 943 ! --- 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 938 949 ! --- SIMIP --- ! 939 950 IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & … … 944 955 & zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 945 956 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) 952 963 ENDIF 953 964 … … 960 971 DO_2D( 0, 0, 0, 0 ) 961 972 ! 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) 964 975 965 976 zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component … … 979 990 980 991 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 982 993 CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s) 983 994 CALL iom_put( 'ymtrpsnw' , zdiag_ymtrp_snw ) ! Y-component of snow mass transport … … 995 1006 IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 996 1007 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(:,:) ) 998 1009 ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 999 1010 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(:,:) ) 1001 1012 ENDIF 1002 1013 ENDIF 1003 ENDIF 1004 ! 1005 DEALLOCATE( zmsk00, zmsk15 ) 1014 ENDIF 1006 1015 ! 1007 1016 END SUBROUTINE ice_dyn_rhg_eap 1008 1017 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 ) 1011 1020 !!---------------------------------------------------------------------- 1012 !! *** ROUTINE rhg_cvg ***1013 !! 1021 !! *** ROUTINE rhg_cvg_eap *** 1022 !! 1014 1023 !! ** Purpose : check convergence of oce rheology 1015 1024 !! … … 1019 1028 !! This routine is called every sub-iteration, so it is cpu expensive 1020 1029 !! 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) 1022 1031 !!---------------------------------------------------------------------- 1023 1032 INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index … … 1026 1035 INTEGER :: it, idtime, istatus 1027 1036 INTEGER :: ji, jj ! dummy loop indices 1028 REAL(wp) :: zresm ! local real 1037 REAL(wp) :: zresm ! local real 1029 1038 CHARACTER(len=20) :: clname 1030 REAL(wp), DIMENSION(jpi,jpj) :: zres ! check convergence1031 1039 !!---------------------------------------------------------------------- 1032 1040 … … 1036 1044 IF( lwp ) THEN 1037 1045 WRITE(numout,*) 1038 WRITE(numout,*) 'rhg_cvg : ice rheology convergence control'1046 WRITE(numout,*) 'rhg_cvg_eap : ice rheology convergence control' 1039 1047 WRITE(numout,*) '~~~~~~~' 1040 1048 ENDIF … … 1053 1061 ! time 1054 1062 it = ( kt - 1 ) * kitermax + kiter 1055 1063 1056 1064 ! convergence 1057 1065 IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large) … … 1059 1067 ELSE 1060 1068 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 1063 1075 END_2D 1064 1076 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 ) 1070 1078 CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain 1071 1079 ENDIF … … 1077 1085 IF( kt == nitend ) istatus = NF90_CLOSE(ncvgid) 1078 1086 ENDIF 1079 1080 END SUBROUTINE rhg_cvg 1087 1088 END SUBROUTINE rhg_cvg_eap 1081 1089 1082 1090 … … 1085 1093 !!--------------------------------------------------------------------- 1086 1094 !! *** SUBROUTINE update_stress_rdg *** 1087 !! 1095 !! 1088 1096 !! ** Purpose : Updates the stress depending on values of strain rate and structure 1089 1097 !! tensor and for the last subcycle step it computes closing and sliding rate … … 1098 1106 INTEGER :: kx ,ky, ka 1099 1107 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 1106 1114 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 1118 1124 ! Factor to maintain the same stress as in EVP (see Section 3) 1119 1125 ! Can be set to 1 otherwise 1120 ! zinvstressconviso = 1._wp/(1._wp+kfriction*kfriction)1121 zinvstressconviso = 1._wp1122 1123 zinvsin = 1._wp/sin(2._wp*pphi) * zinvstressconviso1124 !now uses phi as set in higher code1125 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 1126 1132 ! compute eigenvalues, eigenvectors and angles for structure tensor, strain 1127 1133 ! rates … … 1132 1138 zQ12Q12 = rsmall 1133 1139 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 1138 1144 zAngle_denom_gamma = 1._wp/sqrt( ( pa11 - za22 )*( pa11 - za22) + & 1139 1145 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 1142 1148 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 1146 1152 ! 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 1149 1155 ! make first principal value the largest 1150 1156 zatempprime = max(zatempprime, 1.0_wp - zatempprime) 1151 1157 1152 1158 ! 2) strain rate 1153 1159 zdtemp11 = 0.5_wp*(pdivu + ptension) … … 1155 1161 zdtemp22 = 0.5_wp*(pdivu - ptension) 1156 1162 1157 ! here Tan2alpha = 2 dtemp12 / (dtemp11 - dtemp22) 1163 ! here Tan2alpha = 2 dtemp12 / (dtemp11 - dtemp22) 1158 1164 1159 1165 zQd11Qd11 = 1.0_wp … … 1166 1172 ( zdtemp11 - zdtemp22 ) + 4.0_wp*zdtemp12*zdtemp12) 1167 1173 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 1169 1175 zQd12Qd12 = 0.5_wp - ( zdtemp11 - zdtemp22 )*0.5_wp*zAngle_denom_alpha !Sin^2 1170 1176 zQd11Qd12 = zdtemp12*zAngle_denom_alpha !CosSin … … 1177 1183 IF ((ABS(zdtemp1) > rsmall).OR.(ABS(zdtemp2) > rsmall)) THEN 1178 1184 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 1182 1188 IF (zx < rpi*0.25_wp) zx = zx + rpi*2.0_wp 1183 1189 1184 1190 ! y: angle between major principal axis of strain rate and structure 1185 1191 ! tensor 1186 ! y = gamma - alpha 1192 ! y = gamma - alpha 1187 1193 ! Expressesed componently with 1188 1194 ! Tany = (Singamma*Cosgamma - Sinalpha*Cosgamma)/(Cos^2gamma - Sin^alpha) 1189 1195 1190 1196 zTany_1 = zQ11Q12 - zQd11Qd12 1191 1197 zTany_2 = zQ11Q11 - zQd12Qd12 1192 1198 1193 1199 zy = 0._wp 1194 1200 1195 1201 IF ((ABS(zTany_1) > rsmall).OR.(ABS(zTany_2) > rsmall)) THEN 1196 1202 zy = atan2(zTany_1,zTany_2) 1197 1203 ENDIF 1198 1204 1199 1205 ! to make sure y is between 0 and pi 1200 1206 IF (zy > rpi) zy = zy - rpi 1201 1207 IF (zy < 0) zy = zy + rpi 1202 1208 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) 1210 1213 1211 1214 ! % need 8 coords and 8 weights … … 1213 1216 kx = int((zx-rpi*0.25_wp-rpi)*zinvdx) + 1 1214 1217 !!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 1217 1220 ky = int(zy*zinvdy) + 1 1218 1221 !!clem ky = MAX( 1, MIN( ny_yield-1, INT(zy*zinvdy) + 1 ) ) 1219 kyw = ky - zy*zinvdy 1220 1222 kyw = ky - zy*zinvdy 1223 1221 1224 ka = int((zatempprime-0.5_wp)*zinvda) + 1 1222 1225 !!clem ka = MAX( 1, MIN( na_yield-1, INT((zatempprime-0.5_wp)*zinvda) + 1 ) ) 1223 1226 kaw = ka - (zatempprime-0.5_wp)*zinvda 1224 1227 1225 1228 ! % Determine sigma_r(A1,Zeta,y) and sigma_s (see Section A1 of Tsamados 2013) 1226 1229 !!$ zstemp11r = zkxw * kyw * kaw * s11r(kx ,ky ,ka ) & … … 1248 1251 !!$ & + zkxw * (1._wp-kyw) * (1._wp-kaw) * s22r(kx ,ky+1,ka+1) & 1249 1252 !!$ & + (1._wp-zkxw) * (1._wp-kyw) * (1._wp-kaw) * s22r(kx+1,ky+1,ka+1) 1250 !!$ 1253 !!$ 1251 1254 !!$ zstemp11s = zkxw * kyw * kaw * s11s(kx ,ky ,ka ) & 1252 1255 !!$ & + (1._wp-zkxw) * kyw * kaw * s11s(kx+1,ky ,ka ) & … … 1280 1283 zstemp12s = s12s(kx,ky,ka) 1281 1284 zstemp22s = s22s(kx,ky,ka) 1282 1283 1285 1286 1284 1287 ! Calculate mean ice stress over a collection of floes (Equation 3 in 1285 1288 ! Tsamados 2013) 1286 1289 1287 zsig11 = pstrength*(zstemp11r + kfriction*zstemp11s) * zinvsin1288 zsig12 = pstrength*(zstemp12r + kfriction*zstemp12s) * zinvsin1289 zsig22 = pstrength*(zstemp22r + kfriction*zstemp22s) * zinvsin1290 zsig11 = pstrength*(zstemp11r + ppkfriction*zstemp11s) * ppinvsin 1291 zsig12 = pstrength*(zstemp12r + ppkfriction*zstemp12s) * ppinvsin 1292 zsig22 = pstrength*(zstemp22r + ppkfriction*zstemp22s) * ppinvsin 1290 1293 1291 1294 ! Back - rotation of the stress from principal axes into general coordinates … … 1300 1303 pstressm = zsgprm11 - zsgprm22 1301 1304 1302 ! Compute ridging and sliding functions in general coordinates 1305 ! Compute ridging and sliding functions in general coordinates 1303 1306 ! (Equation 11 in Tsamados 2013) 1304 1307 IF (ksub == kndte) THEN … … 1307 1310 zrotstemp12r = zQ11Q11*zstemp12r + zQ11Q12*(zstemp11r-zstemp22r) & 1308 1311 - zQ12Q12*zstemp12r 1309 zrotstemp22r = zQ12Q12*zstemp11r + 2._wp*zQ11Q12* zstemp12r & 1312 zrotstemp22r = zQ12Q12*zstemp11r + 2._wp*zQ11Q12* zstemp12r & 1310 1313 + zQ11Q11*zstemp22r 1311 1314 … … 1314 1317 zrotstemp12s = zQ11Q11*zstemp12s + zQ11Q12*(zstemp11s-zstemp22s) & 1315 1318 - zQ12Q12*zstemp12s 1316 zrotstemp22s = zQ12Q12*zstemp11s + 2._wp*zQ11Q12* zstemp12s & 1319 zrotstemp22s = zQ12Q12*zstemp11s + 2._wp*zQ11Q12* zstemp12s & 1317 1320 + zQ11Q11*zstemp22s 1318 1321 … … 1322 1325 + zrotstemp22s*zdtemp22 1323 1326 ENDIF 1324 END SUBROUTINE update_stress_rdg 1327 END SUBROUTINE update_stress_rdg 1325 1328 1326 1329 !======================================================================= … … 1331 1334 !!--------------------------------------------------------------------- 1332 1335 !! *** ROUTINE calc_ffrac *** 1333 !! 1336 !! 1334 1337 !! ** Purpose : Computes term in evolution equation for structure tensor 1335 1338 !! which determines the ice floe re-orientation due to fracture … … 1346 1349 REAL (wp) :: zQ11, zQ12, zQ11Q11, zQ11Q12, zQ12Q12 1347 1350 1348 !!$ REAL (wp), PARAMETER :: kfrac = 0.0001_wp ! rate of fracture formation1349 REAL (wp), PARAMETER :: kfrac = 1.e-3_wp ! rate of fracture formation1350 REAL (wp), PARAMETER :: threshold = 0.3_wp ! critical confinement ratio1351 !!$ 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 1351 1354 !!--------------------------------------------------------------- 1352 1355 ! 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) 1356 1359 1357 1360 ! Here's the change - no longer calculate gamma, 1358 1361 ! use trig formulation, angle signs are kept correct, don't worry 1359 1362 1360 1363 ! 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 1364 1367 ! error to the calculated angles < rsmall 1365 1368 … … 1373 1376 zsigma22 ) + 4.0_wp*zsigma12*zsigma12) 1374 1377 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 1376 1379 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 1378 1381 ENDIF 1379 1382 … … 1390 1393 ! which leads to the loss of their shape, so we again model it through diffusion 1391 1394 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) 1394 1397 1395 1398 ! Shear faulting … … 1397 1400 pmresult11 = 0.0_wp 1398 1401 pmresult12 = 0.0_wp 1399 ELSEIF ((zsigma_1 <= 0.0_wp).AND.(zsigma_1/zsigma_2 <= threshold)) THEN1400 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) 1402 1405 1403 1406 ! Horizontal spalling 1404 ELSE 1407 ELSE 1405 1408 pmresult11 = 0.0_wp 1406 1409 pmresult12 = 0.0_wp … … 1413 1416 !!--------------------------------------------------------------------- 1414 1417 !! *** ROUTINE rhg_eap_rst *** 1415 !! 1418 !! 1416 1419 !! ** Purpose : Read or write RHG file in restart file 1417 !! 1420 !! 1418 1421 !! ** Method : use of IOM library 1419 1422 !!---------------------------------------------------------------------- … … 1424 1427 INTEGER :: id1, id2, id3, id4, id5 ! local integers 1425 1428 INTEGER :: ix, iy, ip, iz, n, ia ! local integers 1426 1429 1427 1430 INTEGER, PARAMETER :: nz = 100 1428 1431 1429 1432 REAL(wp) :: ainit, xinit, yinit, pinit, zinit 1430 1433 REAL(wp) :: da, dx, dy, dp, dz, a1 … … 1432 1435 !!clem 1433 1436 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 1435 1439 1436 1440 REAL(wp), PARAMETER :: eps6 = 1.0e-6_wp … … 1508 1512 !!$ s22r(ix,iy,ia) = s22r(ix,iy,ia) + 1*w1(ainit+ia*da)* & 1509 1513 !!$ 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) 1511 1515 !!$ s11s(ix,iy,ia) = s11s(ix,iy,ia) + 1*w1(ainit+ia*da)* & 1512 1516 !!$ exp(-w2(ainit+ia*da)*(zinit+iz*dz)*(zinit+iz*dz))* & … … 1543 1547 !!$ ENDDO 1544 1548 1545 !! faster but still very slow => to be improved 1549 !! faster but still very slow => to be improved 1546 1550 zfac = dz/sin(2._wp*pphi) 1547 1551 DO ia = 1, na_yield-1 … … 1549 1553 zw2 = w2(ainit+ia*da) 1550 1554 DO iz = 1, nz 1551 idz = zinit+iz*dz1555 zidz = zinit+iz*dz 1552 1556 ztemp = zw1 * EXP(-zw2*(zinit+iz*dz)*(zinit+iz*dz)) 1553 1557 DO iy = 1, ny_yield 1554 idy = yinit+iy*dy1558 zidy = yinit+iy*dy 1555 1559 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) 1563 1569 END DO 1564 1570 END DO 1565 1571 END DO 1566 1572 END DO 1567 1568 1573 zfac = 1._wp/sin(2._wp*pphi) 1569 1574 ia = na_yield 1570 1575 DO iy = 1, ny_yield 1571 idy = yinit+iy*dy1576 zidy = yinit+iy*dy 1572 1577 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) 1580 1587 ENDDO 1581 1588 ENDDO … … 1611 1618 REAL(wp) :: w1 1612 1619 !!------------------------------------------------------------------- 1613 1620 1614 1621 w1 = - 223.87569446_wp & 1615 1622 & + 2361.21986630_wp*pa & … … 1620 1627 & - 16789.98003081_wp*pa*pa*pa*pa*pa*pa & 1621 1628 & + 3495.82839237_wp*pa*pa*pa*pa*pa*pa*pa 1622 1629 1623 1630 END FUNCTION w1 1624 1631 … … 1631 1638 REAL(wp) :: w2 1632 1639 !!------------------------------------------------------------------- 1633 1640 1634 1641 w2 = - 6670.68911883_wp & 1635 1642 & + 70222.33061536_wp*pa & … … 1640 1647 & - 493379.44906738_wp*pa*pa*pa*pa*pa*pa & 1641 1648 & + 102356.55151800_wp*pa*pa*pa*pa*pa*pa*pa 1642 1649 1643 1650 END FUNCTION w2 1644 1651 1645 FUNCTION s11kr(px,py,pz) 1646 !!------------------------------------------------------------------- 1647 !! Function : s11kr 1648 !!------------------------------------------------------------------- 1652 SUBROUTINE all_skr_sks( px, py, pz, allsk ) 1649 1653 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 1653 1660 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i22 1654 1661 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i22 … … 1659 1666 REAL(wp) :: zHen1t2, zHen2t1 1660 1667 !!------------------------------------------------------------------- 1661 1668 1662 1669 zpih = 0.5_wp*rpi 1663 1670 1664 1671 zn1t2i11 = cos(pz+zpih-pphi) * cos(pz+pphi) 1665 1672 zn1t2i12 = cos(pz+zpih-pphi) * sin(pz+pphi) … … 1687 1694 zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd22 1688 1695 zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd22 1689 1696 1690 1697 IF (-zIIn1t2>=rsmall) THEN 1691 1698 zHen1t2 = 1._wp … … 1693 1700 zHen1t2 = 0._wp 1694 1701 ENDIF 1695 1702 1696 1703 IF (-zIIn2t1>=rsmall) THEN 1697 1704 zHen2t1 = 1._wp … … 1699 1706 zHen2t1 = 0._wp 1700 1707 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) 1707 1713 !!------------------------------------------------------------------- 1708 1714 !! Function : s12kr 1709 1715 !!------------------------------------------------------------------- 1710 REAL(wp), INTENT(in ) :: px,py,pz1711 1712 REAL(wp) :: s12kr, zs12r0, zs21r0, zpih1713 1714 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i221715 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i221716 REAL(wp) :: zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i221717 REAL(wp) :: zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i221718 REAL(wp) :: zd11, zd12, zd221719 REAL(wp) :: zIIn1t2, zIIn2t1, zIIt1t21720 REAL(wp) :: zHen1t2, zHen2t11721 !!-------------------------------------------------------------------1722 zpih = 0.5_wp*rpi1723 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 * zd221744 zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd221745 zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd221746 1747 IF (-zIIn1t2>=rsmall) THEN1748 zHen1t2 = 1._wp1749 ELSE1750 zHen1t2 = 0._wp1751 ENDIF1752 1753 IF (-zIIn2t1>=rsmall) THEN1754 zHen2t1 = 1._wp1755 ELSE1756 zHen2t1 = 0._wp1757 ENDIF1758 1759 1716 zs12r0 = (- zHen1t2 * zn1t2i12 - zHen2t1 * zn2t1i12) 1760 1717 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) 1766 1719 !!------------------------------------------------------------------- 1767 1720 !! Function : s22kr 1768 1721 !!------------------------------------------------------------------- 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) 1823 1723 !!------------------------------------------------------------------- 1824 1724 !! Function : s11ks 1825 1725 !!------------------------------------------------------------------- 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) 1880 1728 !!------------------------------------------------------------------- 1881 1729 !! Function : s12ks 1882 1730 !!------------------------------------------------------------------- 1883 REAL(wp), INTENT(in ) :: px,py,pz1884 1885 REAL(wp) :: s12ks, zs12s0, zs21s0, zpih1886 1887 REAL(wp) :: zn1t2i11, zn1t2i12, zn1t2i21, zn1t2i221888 REAL(wp) :: zn2t1i11, zn2t1i12, zn2t1i21, zn2t1i221889 REAL(wp) :: zt1t2i11, zt1t2i12, zt1t2i21, zt1t2i221890 REAL(wp) :: zt2t1i11, zt2t1i12, zt2t1i21, zt2t1i221891 REAL(wp) :: zd11, zd12, zd221892 REAL(wp) :: zIIn1t2, zIIn2t1, zIIt1t21893 REAL(wp) :: zHen1t2, zHen2t11894 !!-------------------------------------------------------------------1895 zpih = 0.5_wp*rpi1896 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 * zd221917 zIIn2t1 = zn2t1i11 * zd11 + (zn2t1i12 + zn2t1i21) * zd12 + zn2t1i22 * zd221918 zIIt1t2 = zt1t2i11 * zd11 + (zt1t2i12 + zt1t2i21) * zd12 + zt1t2i22 * zd221919 1920 IF (-zIIn1t2>=rsmall) THEN1921 zHen1t2 = 1._wp1922 ELSE1923 zHen1t2 = 0._wp1924 ENDIF1925 1926 IF (-zIIn2t1>=rsmall) THEN1927 zHen2t1 = 1._wp1928 ELSE1929 zHen2t1 = 0._wp1930 ENDIF1931 1932 1731 zs12s0 = sign(1._wp,zIIt1t2+rsmall)*(zHen1t2 * zt1t2i12 + zHen2t1 * zt2t1i12) 1933 1732 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) 1939 1734 !!------------------------------------------------------------------- 1940 1735 !! Function : s22ks 1941 1736 !!------------------------------------------------------------------- 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 1994 1739 1995 1740 #else … … 1997 1742 !! Default option Empty module NO SI3 sea-ice model 1998 1743 !!---------------------------------------------------------------------- 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 1999 1760 #endif 2000 1761 -
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_iomput1 bld::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 91 91 92 92 ! !!! 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. 95 95 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 96 96 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_mpi1 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_iomput1 bld::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_mpi1 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 46 46 </file> 47 47 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="s KEf" 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" /> 58 58 </file> 59 59 -
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 1 bld::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 17 17 USE dom_oce , ONLY : glamt, gphit, glamu, gphiu, glamv, gphiv 18 18 USE phycst ! physical constants 19 USE eosbn2 , ONLY : rn_a0 19 20 ! 20 21 USE in_out_manager ! I/O manager … … 85 86 & * EXP(-(zx**2+zy**2)/zlambda**2) / (grav*(zH -1._wp + EXP(-zH))); 86 87 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) 88 89 END DO 89 90 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.