Changeset 13984
- Timestamp:
- 2020-12-02T12:35:34+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/SI3_vp_rheology
- Files:
-
- 113 edited
- 7 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/SI3_vp_rheology
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette @13559sette10 ^/utils/CI/sette_MPI3_LoopFusion@13943 sette
-
- Property svn:externals
-
NEMO/branches/2020/SI3_vp_rheology/cfgs/SHARED/namelist_ref
r13731 r13984 94 94 ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present 95 95 ! ! in netcdf input files, as the start j-row for reading 96 / 97 !----------------------------------------------------------------------- 98 &namtile ! parameters of the tiling 99 !----------------------------------------------------------------------- 100 ln_tile = .false. ! Use tiling (T) or not (F) 101 nn_ltile_i = 10 ! Length of tiles in i 102 nn_ltile_j = 10 ! Length of tiles in j 96 103 / 97 104 !----------------------------------------------------------------------- -
NEMO/branches/2020/SI3_vp_rheology/doc/latex/NEMO/main/bibliography.bib
r12377 r13984 1906 1906 } 1907 1907 1908 @Article{ love_PRSLA1909, 1909 author = "A. E. H. Love", 1910 title = "The Yielding of the Earth to Disturbing Forces", 1911 journal = "Proc. R. Soc. Lond. A", 1912 year = "1909", 1913 volume = "82", 1914 pages = "73-88", 1915 doi = "10.1098/rspa.1909.0008" 1916 } 1917 1908 1918 @article{ losch_JGR08, 1909 1919 title = "Modeling ice shelf cavities in a z coordinate Ocean -
NEMO/branches/2020/SI3_vp_rheology/doc/latex/NEMO/subfiles/chap_DIA.tex
r12377 r13984 119 119 \subsection{XIOS: Reading and writing restart file} 120 120 121 XIOS may be used to read single file restart produced by \NEMO. Currently only the variables written to 122 file \forcode{numror} can be handled by XIOS. To activate restart reading using XIOS, set \np[=.true. ]{ln_xios_read}{ln\_xios\_read} 121 XIOS may be used to read single file restart produced by \NEMO. The variables written to 122 file \forcode{numror} (OCE), \forcode{numrir} (SI3), \forcode{numrtr} (TOP), \forcode{numrsr} (SED) can be handled by XIOS. 123 To activate restart reading using XIOS, set \np[=.true. ]{ln_xios_read}{ln\_xios\_read} 123 124 in \textit{namelist\_cfg}. This setting will be ignored when multiple restart files are present, and default \NEMO 124 125 functionality will be used for reading. There is no need to change iodef.xml file to use XIOS to read … … 142 143 have to be rebuild before continuing the run. This option aims to reduce number of restart files generated by \NEMO\ only, 143 144 and may be useful when there is a need to change number of processors used to run simulation. 144 145 If an additional variable must be written to a restart file, the following steps are needed:146 \begin{enumerate}147 \item Add variable name to a list of restart variables (in subroutine \rou{iom\_set\_rst\_vars,} \mdl{iom}) and148 define correct grid for the variable (\forcode{grid_N_3D} - 3D variable, \forcode{grid_N} - 2D variable, \forcode{grid_vector} -149 1D variable, \forcode{grid_scalar} - scalar),150 \item Add variable to the list of fields written by restart. This can be done either in subroutine151 \rou{iom\_set\_rstw\_core} (\mdl{iom}) or by calling \rou{iom\_set\_rstw\_active} (\mdl{iom}) with the name of a variable152 as an argument. This convention follows approach for writing restart using iom, where variables are153 written either by \rou{rst\_write} or by calling \rou{iom\_rstput} from individual routines.154 \end{enumerate}155 145 156 146 An older versions of XIOS do not support reading functionality. It's recommended to use at least XIOS2@1451. -
NEMO/branches/2020/SI3_vp_rheology/doc/latex/NEMO/subfiles/chap_DYN.tex
r11693 r13984 1245 1245 the atmospheric pressure is taken into account when computing the surface pressure gradient. 1246 1246 1247 (2) When \np[=.true.]{ln_tide_pot}{ln\_tide\_pot} and \np[=.true.]{ln_tide}{ln\_tide} (see \autoref{sec:SBC_ tide}),1247 (2) When \np[=.true.]{ln_tide_pot}{ln\_tide\_pot} and \np[=.true.]{ln_tide}{ln\_tide} (see \autoref{sec:SBC_TDE}), 1248 1248 the tidal potential is taken into account when computing the surface pressure gradient. 1249 1249 -
NEMO/branches/2020/SI3_vp_rheology/doc/latex/NEMO/subfiles/chap_LBC.tex
r11693 r13984 16 16 Release & Author(s) & Modifications \\ 17 17 \hline 18 {\em next} & {\em Simon M{\" u}ller} & {\em Minor update of \autoref{subsec:LBC_bdy_tides}} \\[2mm] 18 19 {\em 4.0} & {\em ...} & {\em ...} \\ 19 20 {\em 3.6} & {\em ...} & {\em ...} \\ … … 665 666 666 667 Tidal forcing at open boundaries requires the activation of surface 667 tides (i.e., in \nam{_tide}{\_tide}, \np{ln_tide}{ln\_tide} needs to be set to 668 \forcode{.true.} and the required constituents need to be activated by 669 including their names in the \np{clname}{clname} array; see 670 \autoref{sec:SBC_tide}). Specific options related to the reading in of 668 tides (i.e., in \nam{_tide}{\_tide}, \np[=.true.]{ln_tide}{ln\_tide} with the active tidal 669 constituents listed in the \np{sn_tide_cnames}{sn\_tide\_cnames} array; see 670 \autoref{sec:SBC_TDE}). The specific options related to the reading in of 671 671 the complex harmonic amplitudes of elevation (SSH) and barotropic 672 velocity (u,v) atopen boundaries are defined through the673 \nam{bdy_tide}{bdy\_tide} namelist parameters.\ \672 velocity components (u,v) at the open boundaries are defined through the 673 \nam{bdy_tide}{bdy\_tide} namelist parameters.\par 674 674 675 675 The tidal harmonic data at open boundaries can be specified in two 676 676 different ways, either on a two-dimensional grid covering the entire 677 677 model domain or along open boundary segments; these two variants can 678 be selected by setting \np{ln_bdytide_2ddta }{ln\_bdytide\_2ddta } to \forcode{.true.} or 679 \forcode{.false.}, respectively. In either case, the real and 680 imaginary parts of SSH and the two barotropic velocity components for 681 each activated tidal constituent \textit{tcname} have to be provided 682 separately: when two-dimensional data is used, variables 683 \textit{tcname\_z1} and \textit{tcname\_z2} for real and imaginary SSH, 684 respectively, are expected in input file \np{filtide}{filtide} with suffix 685 \ifile{\_grid\_T}, variables \textit{tcname\_u1} and 686 \textit{tcname\_u2} for real and imaginary u, respectively, are 687 expected in input file \np{filtide}{filtide} with suffix \ifile{\_grid\_U}, and 688 \textit{tcname\_v1} and \textit{tcname\_v2} for real and imaginary v, 689 respectively, are expected in input file \np{filtide}{filtide} with suffix 690 \ifile{\_grid\_V}; when data along open boundary segments is used, 691 variables \textit{z1} and \textit{z2} (real and imaginary part of SSH) 692 are expected to be available from file \np{filtide}{filtide} with suffix 693 \ifile{tcname\_grid\_T}, variables \textit{u1} and \textit{u2} (real 694 and imaginary part of u) are expected to be available from file 695 \np{filtide}{filtide} with suffix \ifile{tcname\_grid\_U}, and variables 696 \textit{v1} and \textit{v2} (real and imaginary part of v) are 697 expected to be available from file \np{filtide}{filtide} with suffix 698 \ifile{tcname\_grid\_V}. If \np{ln_bdytide_conj}{ln\_bdytide\_conj} is set to 699 \forcode{.true.}, the data is expected to be in complex conjugate 700 form. 678 be selected by setting \np[=.true.]{ln_bdytide_2ddta}{ln\_bdytide\_2ddta} or 679 \np[=.false.]{ln_bdytide_2ddta}{ln\_bdytide\_2ddta}, respectively. In either 680 case, the real and imaginary parts of SSH, u, and v amplitudes associated with 681 each activated tidal constituent \texttt{<constituent>} have to be provided 682 separately as fields in input files with names based on 683 \np[=<input>]{filtide}{filtide}: when two-dimensional data is used, variables 684 \texttt{<constituent>\_z1} and \texttt{<constituent>\_z2} for the real and imaginary parts of 685 SSH, respectively, are expected to be available in file 686 \ifile{<input>\_grid\_T}, variables \texttt{<constituent>\_u1} and 687 \texttt{<constituent>\_u2} for the real and imaginary parts of u, respectively, in file 688 \ifile{<input>\_grid\_U}, and \texttt{<constituent>\_v1} and 689 \texttt{<constituent>\_v2} for the real and imaginary parts of v, respectively, in file 690 \ifile{<input>\_grid\_V}; when data along open boundary segments is used, 691 variables \texttt{z1} and \texttt{z2} (real and imaginary part of SSH) are 692 expected to be available in file \ifile{<input><constituent>\_grid\_T}, 693 variables \texttt{u1} and \texttt{u2} (real and imaginary part of u) in file 694 \ifile{<input><constituent>\_grid\_U}, and variables \texttt{v1} and \texttt{v2} 695 (real and imaginary part of v) in file 696 \ifile{<input><constituent>\_grid\_V}.\par 701 697 702 698 Note that the barotropic velocity components are assumed to be defined -
NEMO/branches/2020/SI3_vp_rheology/doc/latex/NEMO/subfiles/chap_SBC.tex
r13165 r13984 5 5 \begin{document} 6 6 7 \chapter{Surface Boundary Condition (SBC, SAS, ISF, ICB )}7 \chapter{Surface Boundary Condition (SBC, SAS, ISF, ICB, TDE)} 8 8 \label{chap:SBC} 9 9 … … 18 18 Release & Author(s) & Modifications \\ 19 19 \hline 20 {\em next} & {\em Simon M{\" u}ller} & {\em Update of \autoref{sec:SBC_TDE}}\\[2mm] 20 21 {\em 4.0} & {\em ...} & {\em ...} \\ 21 22 {\em 3.6} & {\em ...} & {\em ...} \\ … … 1013 1014 1014 1015 %% ================================================================================================= 1015 \section [Surface tides (\textit{sbctide.F90})]{Surface tides (\protect\mdl{sbctide})}1016 \label{sec:SBC_ tide}1016 \section{Surface tides (TDE)} 1017 \label{sec:SBC_TDE} 1017 1018 1018 1019 \begin{listing} … … 1022 1023 \end{listing} 1023 1024 1024 The tidal forcing, generated by the gravity forces of the Earth-Moon and Earth-Sun sytems, 1025 is activated if \np{ln_tide}{ln\_tide} and \np{ln_tide_pot}{ln\_tide\_pot} are both set to \forcode{.true.} in \nam{_tide}{\_tide}. 1026 This translates as an additional barotropic force in the momentum \autoref{eq:MB_PE_dyn} such that: 1025 \subsection{Tidal constituents} 1026 Ocean model component TDE provides the common functionality for tidal forcing 1027 and tidal analysis in the model framework. This includes the computation of the gravitational 1028 surface forcing, as well as support for lateral forcing at open boundaries (see 1029 \autoref{subsec:LBC_bdy_tides}) and tidal harmonic analysis (see 1030 \autoref{subsec:DIA_diamlr} and \autoref{subsec:DIA_diadetide}). The module is 1031 activated with \np[=.true.]{ln_tide}{ln\_tide} in namelist 1032 \nam{_tide}{\_tide}. It provides the same 34 tidal constituents that are 1033 included in the 1034 \href{https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html}{FES2014 1035 ocean tide model}: Mf, Mm, Ssa, Mtm, Msf, Msqm, Sa, K1, O1, P1, Q1, J1, S1, 1036 M2, S2, N2, K2, nu2, mu2, 2N2, L2, T2, eps2, lam2, R2, M3, MKS2, MN4, MS4, M4, 1037 N4, S4, M6, and M8; see file \hf{tide} and \mdl{tide\_mod} for further 1038 information and references\footnote{As a legacy option \np{ln_tide_var} can be 1039 set to \forcode{0}, in which case the 19 tidal constituents (M2, N2, 2N2, S2, 1040 K2, K1, O1, Q1, P1, M4, Mf, Mm, Msqm, Mtm, S1, MU2, NU2, L2, and T2; see file 1041 \hf{tide}) and associated parameters that have been available in NEMO version 1042 4.0 and earlier are available}. Constituents to be included in the tidal forcing 1043 (surface and lateral boundaries) are selected by enumerating their respective 1044 names in namelist array \np{sn_tide_cnames}{sn\_tide\_cnames}.\par 1045 1046 \subsection{Surface tidal forcing} 1047 Surface tidal forcing can be represented in the model through an additional 1048 barotropic force in the momentum equation (\autoref{eq:MB_PE_dyn}) such that: 1027 1049 \[ 1028 % \label{eq:SBC_PE_dyn_tides} 1029 \frac{\partial {\mathrm {\mathbf U}}_h }{\partial t}= ... 1030 +g\nabla (\Pi_{eq} + \Pi_{sal}) 1050 \frac{\partial {\mathrm {\mathbf U}}_h }{\partial t} = \ldots +g\nabla (\gamma 1051 \Pi_{eq} + \Pi_{sal}) 1031 1052 \] 1032 where $\Pi_{eq}$ stands for the equilibrium tidal forcing and 1033 $\Pi_{sal}$ is a self-attraction and loading term (SAL). 1034 1035 The equilibrium tidal forcing is expressed as a sum over a subset of 1036 constituents chosen from the set of available tidal constituents 1037 defined in file \hf{SBC/tide} (this comprises the tidal 1038 constituents \textit{M2, N2, 2N2, S2, K2, K1, O1, Q1, P1, M4, Mf, Mm, 1039 Msqm, Mtm, S1, MU2, NU2, L2}, and \textit{T2}). Individual 1040 constituents are selected by including their names in the array 1041 \np{clname}{clname} in \nam{_tide}{\_tide} (e.g., \np{clname}{clname}\forcode{(1)='M2', } 1042 \np{clname}{clname}\forcode{(2)='S2'} to select solely the tidal consituents \textit{M2} 1043 and \textit{S2}). Optionally, when \np{ln_tide_ramp}{ln\_tide\_ramp} is set to 1044 \forcode{.true.}, the equilibrium tidal forcing can be ramped up 1045 linearly from zero during the initial \np{rdttideramp}{rdttideramp} days of the 1046 model run. 1053 where $\gamma \Pi_{eq}$ stands for the equilibrium tidal forcing scaled by a spatially 1054 uniform tilt factor $\gamma$, and $\Pi_{sal}$ is an optional 1055 self-attraction and loading term (SAL). These additional terms are enabled when, 1056 in addition to \np[=.true.]{ln_tide}{ln\_tide}), 1057 \np[=.true.]{ln_tide_pot}{ln\_tide\_pot}.\par 1058 1059 The equilibrium tidal forcing is expressed as a sum over the subset of 1060 constituents listed in \np{sn_tide_cnames}{sn\_tide\_cnames} of 1061 \nam{_tide} (e.g., 1062 \begin{forlines} 1063 sn_tide_cnames(1) = 'M2' 1064 sn_tide_cnames(2) = 'K1' 1065 sn_tide_cnames(3) = 'S2' 1066 sn_tide_cnames(4) = 'O1' 1067 \end{forlines} 1068 to select the four tidal constituents of strongest equilibrium tidal 1069 potential). The tidal tilt factor $\gamma = 1 + k - h$ includes the 1070 Love numbers $k$ and $h$ \citep{love_prsla1909}; this factor is 1071 configurable using \np{rn_tide_gamma} (default value 0.7). Optionally, 1072 when \np[=.true.]{ln_tide_ramp}{ln\_tide\_ramp}, the equilibrium tidal 1073 forcing can be ramped up linearly from zero during the initial 1074 \np{rn_tide_ramp_dt}{rn\_tide\_ramp\_dt} days of the model run.\par 1047 1075 1048 1076 The SAL term should in principle be computed online as it depends on 1049 1077 the model tidal prediction itself (see \citet{arbic.garner.ea_DSR04} for a 1050 discussion about the practical implementation of this term). 1051 Nevertheless, the complex calculations involved would make this 1052 computationally too expensive. Here, two options are available: 1053 $\Pi_{sal}$ generated by an external model can be read in 1054 (\np[=.true.]{ln_read_load}{ln\_read\_load}), or a ``scalar approximation'' can be 1055 used (\np[=.true.]{ln_scal_load}{ln\_scal\_load}). In the latter case 1078 discussion about the practical implementation of this term). The complex 1079 calculations involved in such computations, however, are computationally very 1080 expensive. Here, two mutually exclusive simpler variants are available: 1081 amplitudes generated by an external model for oscillatory $\Pi_{sal}$ 1082 contributions from each of the selected tidal constituents can be read in 1083 (\np[=.true.]{ln_read_load}{ln\_read\_load}) from the file specified in 1084 \np{cn_tide_load}{cn\_tide\_load} (the variable names are comprised of the 1085 tidal-constituent name and suffixes \forcode{_z1} and \forcode{_z2} for the two 1086 orthogonal components, respectively); alternatively, a ``scalar approximation'' 1087 can be used (\np[=.true.]{ln_scal_load}{ln\_scal\_load}), where 1056 1088 \[ 1057 1089 \Pi_{sal} = \beta \eta, 1058 1090 \] 1059 where $\beta$ (\np{rn_scal_load}{rn\_scal\_load} with a default value of 0.094) is a 1060 spatially constant scalar, often chosen to minimize tidal prediction 1061 errors. Setting both \np{ln_read_load}{ln\_read\_load} and \np{ln_scal_load}{ln\_scal\_load} to 1062 \forcode{.false.} removes the SAL contribution. 1091 with a spatially uniform coefficient $\beta$, which can be configured 1092 via \np{rn_scal_load}{rn\_scal\_load} (default value 0.094) and is 1093 often tuned to minimize tidal prediction errors.\par 1094 1095 For diagnostic purposes, the forcing potential of the individual tidal 1096 constituents (incl. load ptential, if activated) and the total forcing 1097 potential (incl. load potential, if activated) can be made available 1098 as diagnostic output by setting 1099 \np[=.true.]{ln_tide_dia}{ln\_tide\_dia} (fields 1100 \forcode{tide_pot_<constituent>} and \forcode{tide_pot}).\par 1063 1101 1064 1102 %% ================================================================================================= -
NEMO/branches/2020/SI3_vp_rheology/doc/namelists/nam_tide
r10075 r13984 3 3 !----------------------------------------------------------------------- 4 4 ln_tide = .false. ! Activate tides 5 ln_tide_pot = .true. ! use tidal potential forcing 5 nn_tide_var = 1 ! Variant of tidal parameter set and tide-potential computation 6 ! ! (1: default; 0: compatibility with previous versions) 7 ln_tide_dia = .false. ! Enable tidal diagnostic output 8 ln_tide_pot = .false. ! use tidal potential forcing 9 rn_tide_gamma = 0.7 ! Tidal tilt factor 6 10 ln_scal_load = .false. ! Use scalar approximation for 7 11 rn_scal_load = 0.094 ! load potential 8 12 ln_read_load = .false. ! Or read load potential from file 9 13 cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential 10 ! 14 ! 11 15 ln_tide_ramp = .false. ! Use linear ramp for tides at startup 12 r dttideramp = 0.! ramp duration in days13 clname(1)= 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg16 rn_tide_ramp_dt = 0. ! ramp duration in days 17 sn_tide_cnames(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg 14 18 / -
NEMO/branches/2020/SI3_vp_rheology/doc/namelists/nambdy_tide
r10075 r13984 4 4 filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files 5 5 ln_bdytide_2ddta = .false. ! 6 ln_bdytide_conj = .false. !7 6 / -
NEMO/branches/2020/SI3_vp_rheology/src/ICE/icedia.F90
r13286 r13984 261 261 ! Write in numriw (if iter == nitrst) 262 262 ! ------------------ 263 CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop 264 CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot 265 CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop 266 CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot 267 CALL iom_rstput( iter, nitrst, numriw, 'frc_sal' , frc_sal 263 CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop ) 264 CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot ) 265 CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop ) 266 CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot ) 267 CALL iom_rstput( iter, nitrst, numriw, 'frc_sal' , frc_sal ) 268 268 CALL iom_rstput( iter, nitrst, numriw, 'vol_loc_ini', vol_loc_ini ) 269 269 CALL iom_rstput( iter, nitrst, numriw, 'tem_loc_ini', tem_loc_ini ) -
NEMO/branches/2020/SI3_vp_rheology/src/ICE/icedyn_adv_pra.F90
r13637 r13984 989 989 DO jk = 1, nlay_s 990 990 WRITE(zchar1,'(I2.2)') jk 991 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 992 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 993 znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 994 znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) 995 znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) 991 znam = 'sxc0'//'_l'//zchar1 992 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 993 znam = 'syc0'//'_l'//zchar1 994 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 995 znam = 'sxxc0'//'_l'//zchar1 996 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 997 znam = 'syyc0'//'_l'//zchar1 998 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) 999 znam = 'sxyc0'//'_l'//zchar1 1000 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) 996 1001 END DO 997 1002 ! ! ice layers heat content 998 1003 DO jk = 1, nlay_i 999 1004 WRITE(zchar1,'(I2.2)') jk 1000 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxe (:,:,jk,:) = z3d(:,:,:) 1001 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sye (:,:,jk,:) = z3d(:,:,:) 1002 znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 1003 znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) 1004 znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) 1005 znam = 'sxe'//'_l'//zchar1 1006 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxe (:,:,jk,:) = z3d(:,:,:) 1007 znam = 'sye'//'_l'//zchar1 1008 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sye (:,:,jk,:) = z3d(:,:,:) 1009 znam = 'sxxe'//'_l'//zchar1 1010 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 1011 znam = 'syye'//'_l'//zchar1 1012 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) 1013 znam = 'sxye'//'_l'//zchar1 1014 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) 1005 1015 END DO 1006 1016 ! … … 1067 1077 ! 1068 1078 ! ! ice thickness 1069 CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice 1070 CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice 1071 CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice 1072 CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice 1073 CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice 1079 CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice) 1080 CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice) 1081 CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice) 1082 CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice) 1083 CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice) 1074 1084 ! ! snow thickness 1075 CALL iom_rstput( iter, nitrst, numriw, 'sxsn' , sxsn 1076 CALL iom_rstput( iter, nitrst, numriw, 'sysn' , sysn 1077 CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn 1078 CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn 1079 CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn 1085 CALL iom_rstput( iter, nitrst, numriw, 'sxsn' , sxsn ) 1086 CALL iom_rstput( iter, nitrst, numriw, 'sysn' , sysn ) 1087 CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn ) 1088 CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn ) 1089 CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn ) 1080 1090 ! ! ice concentration 1081 CALL iom_rstput( iter, nitrst, numriw, 'sxa' , sxa 1082 CALL iom_rstput( iter, nitrst, numriw, 'sya' , sya 1083 CALL iom_rstput( iter, nitrst, numriw, 'sxxa' , sxxa 1084 CALL iom_rstput( iter, nitrst, numriw, 'syya' , syya 1085 CALL iom_rstput( iter, nitrst, numriw, 'sxya' , sxya 1091 CALL iom_rstput( iter, nitrst, numriw, 'sxa' , sxa ) 1092 CALL iom_rstput( iter, nitrst, numriw, 'sya' , sya ) 1093 CALL iom_rstput( iter, nitrst, numriw, 'sxxa' , sxxa ) 1094 CALL iom_rstput( iter, nitrst, numriw, 'syya' , syya ) 1095 CALL iom_rstput( iter, nitrst, numriw, 'sxya' , sxya ) 1086 1096 ! ! ice salinity 1087 CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal 1088 CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal 1089 CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal 1090 CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal 1091 CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal 1097 CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal) 1098 CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal) 1099 CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal) 1100 CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal) 1101 CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal) 1092 1102 ! ! ice age 1093 CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage 1094 CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage 1095 CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage 1096 CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage 1097 CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage 1103 CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage) 1104 CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage) 1105 CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage) 1106 CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage) 1107 CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage) 1098 1108 ! ! snow layers heat content 1099 1109 DO jk = 1, nlay_s 1100 1110 WRITE(zchar1,'(I2.2)') jk 1101 znam = 'sxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1102 znam = 'syc0'//'_l'//zchar1 ; z3d(:,:,:) = syc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1103 znam = 'sxxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxxc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1104 znam = 'syyc0'//'_l'//zchar1 ; z3d(:,:,:) = syyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1105 znam = 'sxyc0'//'_l'//zchar1 ; z3d(:,:,:) = sxyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1111 znam = 'sxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxc0 (:,:,jk,:) 1112 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1113 znam = 'syc0'//'_l'//zchar1 ; z3d(:,:,:) = syc0 (:,:,jk,:) 1114 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1115 znam = 'sxxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxxc0(:,:,jk,:) 1116 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1117 znam = 'syyc0'//'_l'//zchar1 ; z3d(:,:,:) = syyc0(:,:,jk,:) 1118 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1119 znam = 'sxyc0'//'_l'//zchar1 ; z3d(:,:,:) = sxyc0(:,:,jk,:) 1120 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1106 1121 END DO 1107 1122 ! ! ice layers heat content 1108 1123 DO jk = 1, nlay_i 1109 1124 WRITE(zchar1,'(I2.2)') jk 1110 znam = 'sxe'//'_l'//zchar1 ; z3d(:,:,:) = sxe (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1111 znam = 'sye'//'_l'//zchar1 ; z3d(:,:,:) = sye (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1112 znam = 'sxxe'//'_l'//zchar1 ; z3d(:,:,:) = sxxe(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1113 znam = 'syye'//'_l'//zchar1 ; z3d(:,:,:) = syye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1114 znam = 'sxye'//'_l'//zchar1 ; z3d(:,:,:) = sxye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1125 znam = 'sxe'//'_l'//zchar1 ; z3d(:,:,:) = sxe (:,:,jk,:) 1126 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1127 znam = 'sye'//'_l'//zchar1 ; z3d(:,:,:) = sye (:,:,jk,:) 1128 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1129 znam = 'sxxe'//'_l'//zchar1 ; z3d(:,:,:) = sxxe(:,:,jk,:) 1130 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1131 znam = 'syye'//'_l'//zchar1 ; z3d(:,:,:) = syye(:,:,jk,:) 1132 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1133 znam = 'sxye'//'_l'//zchar1 ; z3d(:,:,:) = sxye(:,:,jk,:) 1134 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1115 1135 END DO 1116 1136 ! -
NEMO/branches/2020/SI3_vp_rheology/src/ICE/icedyn_rhg_evp.F90
r13612 r13984 199 199 zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 200 200 END_2D 201 CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp 201 CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp) 202 202 203 203 ! Lateral boundary conditions on velocity (modify zfmask) … … 1033 1033 iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 1034 1034 ! 1035 CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i 1036 CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i 1035 CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i ) 1036 CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i ) 1037 1037 CALL iom_rstput( iter, nitrst, numriw, 'stress12_i', stress12_i ) 1038 1038 ! -
NEMO/branches/2020/SI3_vp_rheology/src/ICE/icerst.F90
r13472 r13984 55 55 CHARACTER(len=50) :: clname ! ice output restart file name 56 56 CHARACTER(len=256) :: clpath ! full path to ice output restart file 57 CHARACTER(LEN=52) :: clpname ! ocean output restart file name including prefix for AGRIF 57 58 !!---------------------------------------------------------------------- 58 59 ! … … 84 85 ENDIF 85 86 ! 86 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 87 IF(.NOT.lwxios) THEN 88 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 89 ELSE 90 #if defined key_iomput 91 cw_icerst_cxt = "rstwi_"//TRIM(ADJUSTL(clkt)) 92 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 93 clpname = clname 94 ELSE 95 clpname = TRIM(Agrif_CFixed())//"_"//clname 96 ENDIF 97 numriw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 98 CALL iom_init( cw_icerst_cxt, kdid = numriw, ld_closedef = .FALSE. ) 99 CALL iom_swap( cxios_context ) 100 #else 101 clinfo = 'Can not use XIOS in rst_opn' 102 CALL ctl_stop(TRIM(clinfo)) 103 #endif 104 ENDIF 87 105 lrst_ice = .TRUE. 88 106 ENDIF … … 117 135 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 118 136 ENDIF 119 137 120 138 ! Write in numriw (if iter == nitrst) 121 139 ! ------------------ … … 123 141 CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) ) ! time-step 124 142 CALL iom_rstput( iter, nitrst, numriw, 'kt_ice' , REAL( iter , wp ) ) ! date 125 CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables 143 144 IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables 126 145 127 146 ! Prognostic variables … … 154 173 IF( ln_cpl ) THEN 155 174 CALL iom_rstput( iter, nitrst, numriw, 'cnd_ice', cnd_ice ) 156 CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice 175 CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice ) 157 176 ENDIF 158 177 ! … … 161 180 ! ------------------ 162 181 IF( iter == nitrst ) THEN 163 CALL iom_close( numriw ) 182 IF(.NOT.lwxios) THEN 183 CALL iom_close( numriw ) 184 ELSE 185 CALL iom_context_finalize( cw_icerst_cxt ) 186 iom_file(numriw)%nfid = 0 187 numriw = 0 188 ENDIF 164 189 lrst_ice = .FALSE. 165 190 ENDIF … … 181 206 CHARACTER(len=2) :: zchar, zchar1 182 207 REAL(wp) :: zfice, ziter 208 CHARACTER(lc) :: clpname 183 209 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace 184 210 !!---------------------------------------------------------------------- … … 190 216 ENDIF 191 217 218 lxios_sini = .FALSE. 192 219 CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir ) 220 221 IF( lrxios) THEN 222 cr_icerst_cxt = 'si3_rst' 223 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for SI3' 224 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 225 ! clpname = cn_icerst_in 226 ! ELSE 227 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_icerst_in 228 ! ENDIF 229 CALL iom_init( cr_icerst_cxt, kdid = numrir, ld_closedef = .TRUE. ) 230 ENDIF 193 231 194 232 ! test if v_i exists … … 198 236 IF( id0 > 0 ) THEN ! == case of a normal restart == ! 199 237 ! ! ------------------------------ ! 200 201 238 ! Time info 202 239 CALL iom_get( numrir, 'nn_fsbc', zfice ) … … 278 315 ENDIF 279 316 280 CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables 281 317 IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables 282 318 ! ! ---------------------------------- ! 283 319 ELSE ! == case of a simplified restart == ! -
NEMO/branches/2020/SI3_vp_rheology/src/ICE/icestp.F90
r13721 r13984 291 291 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 292 292 ! 293 IF( ln_rstart ) CALL iom_close( numrir ) ! close input ice restart file 293 IF( ln_rstart ) THEN 294 CALL iom_close( numrir ) ! close input ice restart file 295 IF(lrxios) CALL iom_context_finalize( cr_icerst_cxt ) 296 ENDIF 294 297 ! 295 298 END SUBROUTINE ice_init -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ASM/asminc.F90
r13295 r13984 26 26 USE par_oce ! Ocean space and time domain variables 27 27 USE dom_oce ! Ocean space and time domain 28 USE domain, ONLY : dom_tile 28 29 USE domvvl ! domain: variable volume level 29 30 USE ldfdyn ! lateral diffusion: eddy viscosity coefficients … … 518 519 ! 519 520 INTEGER :: ji, jj, jk 520 INTEGER :: it 521 INTEGER :: it, itile 521 522 REAL(wp) :: zincwgt ! IAU weight for current time step 522 REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values523 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values 523 524 !!---------------------------------------------------------------------- 524 525 ! 525 526 ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 526 527 ! used to prevent the applied increments taking the temperature below the local freezing point 527 DO jk = 1, jpkm1 528 CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 529 END DO 528 IF( ln_temnofreeze ) THEN 529 DO jk = 1, jpkm1 530 CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 531 END DO 532 ENDIF 530 533 ! 531 534 ! !-------------------------------------- … … 538 541 zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step 539 542 ! 540 IF(lwp) THEN 541 WRITE(numout,*) 542 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 543 WRITE(numout,*) '~~~~~~~~~~~~' 543 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 544 IF(lwp) THEN 545 WRITE(numout,*) 546 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 547 WRITE(numout,*) '~~~~~~~~~~~~' 548 ENDIF 544 549 ENDIF 545 550 ! … … 548 553 IF (ln_temnofreeze) THEN 549 554 ! Do not apply negative increments if the temperature will fall below freezing 550 WHERE(t_bkginc( :,:,jk) > 0.0_wp .OR. &551 & pts( :,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )552 pts( :,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt555 WHERE(t_bkginc(A2D(0),jk) > 0.0_wp .OR. & 556 & pts(A2D(0),jk,jp_tem,Kmm) + pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * wgtiau(it) > fzptnz(:,:,jk) ) 557 pts(A2D(0),jk,jp_tem,Krhs) = pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * zincwgt 553 558 END WHERE 554 559 ELSE 555 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 560 DO_2D( 0, 0, 0, 0 ) 561 pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) + t_bkginc(ji,jj,jk) * zincwgt 562 END_2D 556 563 ENDIF 557 564 IF (ln_salfix) THEN 558 565 ! Do not apply negative increments if the salinity will fall below a specified 559 566 ! minimum value salfixmin 560 WHERE(s_bkginc( :,:,jk) > 0.0_wp .OR. &561 & pts( :,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )562 pts( :,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt567 WHERE(s_bkginc(A2D(0),jk) > 0.0_wp .OR. & 568 & pts(A2D(0),jk,jp_sal,Kmm) + pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * wgtiau(it) > salfixmin ) 569 pts(A2D(0),jk,jp_sal,Krhs) = pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * zincwgt 563 570 END WHERE 564 571 ELSE 565 pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 572 DO_2D( 0, 0, 0, 0 ) 573 pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) + s_bkginc(ji,jj,jk) * zincwgt 574 END_2D 566 575 ENDIF 567 576 END DO … … 569 578 ENDIF 570 579 ! 571 IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work 572 DEALLOCATE( t_bkginc ) 573 DEALLOCATE( s_bkginc ) 580 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 581 IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work 582 DEALLOCATE( t_bkginc ) 583 DEALLOCATE( s_bkginc ) 584 ENDIF 574 585 ENDIF 575 586 ! !-------------------------------------- … … 584 595 IF (ln_temnofreeze) THEN 585 596 ! Do not apply negative increments if the temperature will fall below freezing 586 WHERE( t_bkginc( :,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) )587 pts( :,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)597 WHERE( t_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_tem,Kmm) + t_bkginc(A2D(0),:) > fzptnz(:,:,:) ) 598 pts(A2D(0),:,jp_tem,Kmm) = t_bkg(A2D(0),:) + t_bkginc(A2D(0),:) 588 599 END WHERE 589 600 ELSE 590 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 601 DO_3D( 0, 0, 0, 0, 1, jpk ) 602 pts(ji,jj,jk,jp_tem,Kmm) = t_bkg(ji,jj,jk) + t_bkginc(ji,jj,jk) 603 END_3D 591 604 ENDIF 592 605 IF (ln_salfix) THEN 593 606 ! Do not apply negative increments if the salinity will fall below a specified 594 607 ! minimum value salfixmin 595 WHERE( s_bkginc( :,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin )596 pts( :,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)608 WHERE( s_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_sal,Kmm) + s_bkginc(A2D(0),:) > salfixmin ) 609 pts(A2D(0),:,jp_sal,Kmm) = s_bkg(A2D(0),:) + s_bkginc(A2D(0),:) 597 610 END WHERE 598 611 ELSE 599 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 600 ENDIF 601 602 pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm) ! Update before fields 612 DO_3D( 0, 0, 0, 0, 1, jpk ) 613 pts(ji,jj,jk,jp_sal,Kmm) = s_bkg(ji,jj,jk) + s_bkginc(ji,jj,jk) 614 END_3D 615 ENDIF 616 617 DO_3D( 0, 0, 0, 0, 1, jpk ) 618 pts(ji,jj,jk,:,Kbb) = pts(ji,jj,jk,:,Kmm) ! Update before fields 619 END_3D 603 620 604 621 CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities … … 607 624 !!gm 608 625 609 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & 610 & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient 611 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 612 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & 613 & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) 614 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level 615 616 DEALLOCATE( t_bkginc ) 617 DEALLOCATE( s_bkginc ) 618 DEALLOCATE( t_bkg ) 619 DEALLOCATE( s_bkg ) 626 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from zps_hde*) 627 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 628 itile = ntile 629 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 630 631 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & 632 & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient 633 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 634 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & 635 & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) 636 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level 637 638 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 639 ENDIF 640 641 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 642 DEALLOCATE( t_bkginc ) 643 DEALLOCATE( s_bkginc ) 644 DEALLOCATE( t_bkg ) 645 DEALLOCATE( s_bkg ) 646 ENDIF 647 ! 620 648 ENDIF 621 649 ! … … 829 857 INTEGER, INTENT(in), OPTIONAL :: kindic ! flag for disabling the deallocation 830 858 ! 859 INTEGER :: ji, jj 831 860 INTEGER :: it 832 861 REAL(wp) :: zincwgt ! IAU weight for current time step 833 862 #if defined key_si3 834 REAL(wp), DIMENSION( jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc863 REAL(wp), DIMENSION(A2D(nn_hls)) :: zofrld, zohicif, zseaicendg, zhicifinc 835 864 REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres 836 865 #endif … … 847 876 ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 848 877 ! 849 IF(lwp) THEN 850 WRITE(numout,*) 851 WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 852 WRITE(numout,*) '~~~~~~~~~~~~' 878 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 879 IF(lwp) THEN 880 WRITE(numout,*) 881 WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 882 WRITE(numout,*) '~~~~~~~~~~~~' 883 ENDIF 853 884 ENDIF 854 885 ! … … 856 887 ! 857 888 #if defined key_si3 858 zofrld (:,:) = 1._wp - at_i(:,:) 859 zohicif(:,:) = hm_i(:,:) 860 ! 861 at_i (:,:) = 1. - MIN( MAX( 1.-at_i (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 862 at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 863 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 864 ! 865 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 889 DO_2D( 0, 0, 0, 0 ) 890 zofrld (ji,jj) = 1._wp - at_i(ji,jj) 891 zohicif(ji,jj) = hm_i(ji,jj) 892 ! 893 at_i (ji,jj) = 1. - MIN( MAX( 1.-at_i (ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 894 at_i_b(ji,jj) = 1. - MIN( MAX( 1.-at_i_b(ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 895 fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction 896 ! 897 zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied 898 END_2D 866 899 ! 867 900 ! Nudge sea ice depth to bring it up to a required minimum depth 868 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i( :,:) < zhicifmin )869 zhicifinc(:,:) = (zhicifmin - hm_i( :,:)) * zincwgt901 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 902 zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt 870 903 ELSEWHERE 871 904 zhicifinc(:,:) = 0.0_wp … … 873 906 ! 874 907 ! nudge ice depth 875 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 908 DO_2D( 0, 0, 0, 0 ) 909 hm_i (ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 910 END_2D 876 911 ! 877 912 ! seaice salinity balancing (to add) … … 880 915 #if defined key_cice && defined key_asminc 881 916 ! Sea-ice : CICE case. Pass ice increment tendency into CICE 882 ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rn_Dt 883 #endif 884 ! 885 IF ( kt == nitiaufin_r ) THEN 886 DEALLOCATE( seaice_bkginc ) 917 DO_2D( 0, 0, 0, 0 ) 918 ndaice_da(ji,jj) = seaice_bkginc(ji,jj) * zincwgt / rn_Dt 919 END_2D 920 #endif 921 ! 922 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 923 IF ( kt == nitiaufin_r ) THEN 924 DEALLOCATE( seaice_bkginc ) 925 ENDIF 887 926 ENDIF 888 927 ! … … 890 929 ! 891 930 #if defined key_cice && defined key_asminc 892 ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 931 DO_2D( 0, 0, 0, 0 ) 932 ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 933 END_2D 893 934 #endif 894 935 ! … … 905 946 ! 906 947 #if defined key_si3 907 zofrld (:,:) = 1._wp - at_i(:,:) 908 zohicif(:,:) = hm_i(:,:) 909 ! 910 ! Initialize the now fields the background + increment 911 at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 912 at_i_b(:,:) = at_i(:,:) 913 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 914 ! 915 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 948 DO_2D( 0, 0, 0, 0 ) 949 zofrld (ji,jj) = 1._wp - at_i(ji,jj) 950 zohicif(ji,jj) = hm_i(ji,jj) 951 ! 952 ! Initialize the now fields the background + increment 953 at_i(ji,jj) = 1. - MIN( MAX( 1.-at_i(ji,jj) - seaice_bkginc(ji,jj), 0.0_wp), 1.0_wp) 954 at_i_b(ji,jj) = at_i(ji,jj) 955 fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction 956 ! 957 zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied 958 END_2D 916 959 ! 917 960 ! Nudge sea ice depth to bring it up to a required minimum depth 918 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i( :,:) < zhicifmin )919 zhicifinc(:,:) = zhicifmin - hm_i( :,:)961 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 962 zhicifinc(:,:) = zhicifmin - hm_i(A2D(0)) 920 963 ELSEWHERE 921 964 zhicifinc(:,:) = 0.0_wp … … 923 966 ! 924 967 ! nudge ice depth 925 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 968 DO_2D( 0, 0, 0, 0 ) 969 hm_i(ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 970 END_2D 926 971 ! 927 972 ! seaice salinity balancing (to add) … … 930 975 #if defined key_cice && defined key_asminc 931 976 ! Sea-ice : CICE case. Pass ice increment tendency into CICE 932 ndaice_da(:,:) = seaice_bkginc(:,:) / rn_Dt 933 #endif 934 IF ( .NOT. PRESENT(kindic) ) THEN 935 DEALLOCATE( seaice_bkginc ) 936 END IF 977 DO_2D( 0, 0, 0, 0 ) 978 ndaice_da(ji,jj) = seaice_bkginc(ji,jj) / rn_Dt 979 END_2D 980 #endif 981 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 982 IF ( .NOT. PRESENT(kindic) ) THEN 983 DEALLOCATE( seaice_bkginc ) 984 END IF 985 ENDIF 937 986 ! 938 987 ELSE 939 988 ! 940 989 #if defined key_cice && defined key_asminc 941 ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 990 DO_2D( 0, 0, 0, 0 ) 991 ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 992 END_2D 942 993 #endif 943 994 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/BDY/bdytra.F90
r13527 r13984 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 15 USE dom_oce ! ocean space and time domain variables 16 16 USE bdy_oce ! ocean open boundary conditions 17 17 USE bdylib ! for orlanski library routines … … 157 157 INTEGER :: ib_bdy ! Loop index 158 158 !!---------------------------------------------------------------------- 159 IF( ntile /= 0 .AND. ntile /= 1 ) RETURN ! Do only for the full domain 159 160 ! 160 161 IF( ln_timing ) CALL timing_start('bdy_tra_dmp') -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/C1D/step_c1d.F90
r13237 r13984 122 122 CALL dyn_atf ( kstp, Nbb, Nnn, Naa , uu, vv, e3t, e3u, e3v ) ! time filtering of "now" fields 123 123 IF(.NOT.ln_linssh)CALL ssh_atf ( kstp, Nbb, Nnn, Naa , ssh ) ! time filtering of "now" sea surface height 124 IF( kstp == nit000 .AND. ln_linssh) THEN 125 ssh(:,:,Naa) = ssh(:,:,Nnn) ! init ssh after in ln_linssh case 126 ENDIF 124 127 ! 125 128 ! Swap time levels -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DIA/diaar5.F90
r13497 r13984 34 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: hstr_adv, hstr_ldf 36 37 37 38 LOGICAL :: l_ar5 … … 54 55 !!---------------------------------------------------------------------- 55 56 ! 56 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 57 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , & 58 & hstr_adv(jpi,jpj,jpts,2), hstr_ldf(jpi,jpj,jpts,2), STAT=dia_ar5_alloc ) 57 59 ! 58 60 CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) … … 304 306 END SUBROUTINE dia_ar5 305 307 306 307 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support, will not output haloes) 309 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 310 !!---------------------------------------------------------------------- 309 311 !! *** ROUTINE dia_ar5_htr *** … … 314 316 INTEGER , INTENT(in ) :: ktra ! tracer index 315 317 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' 316 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: puflx ! u-flux of advection/diffusion317 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: pvflx ! v-flux of advection/diffusion318 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion 319 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion 318 320 ! 319 321 INTEGER :: ji, jj, jk 320 REAL(wp), DIMENSION(jpi,jpj) :: z2d 321 322 323 IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 324 IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 325 326 IF( cptr == 'adv' ) THEN 327 DO_2D( 0, 0, 0, 0 ) 328 hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 329 hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 330 END_2D 331 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 332 hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 333 hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 334 END_3D 335 ELSE IF( cptr == 'ldf' ) THEN 336 DO_2D( 0, 0, 0, 0 ) 337 hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 338 hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 339 END_2D 340 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 341 hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 342 hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 343 END_3D 344 ENDIF 345 346 IF( ntile == 0 .OR. ntile == nijtile ) THEN 347 IF( cptr == 'adv' ) THEN 348 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) ) ! advective heat transport in i-direction 349 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * hstr_adv(:,:,ktra,1) ) ! advective salt transport in i-direction 350 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) ) ! advective heat transport in j-direction 351 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * hstr_adv(:,:,ktra,2) ) ! advective salt transport in j-direction 352 ENDIF 353 IF( cptr == 'ldf' ) THEN 354 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,1) ) ! diffusive heat transport in i-direction 355 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * hstr_ldf(:,:,ktra,1) ) ! diffusive salt transport in i-direction 356 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 357 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 358 ENDIF 359 ENDIF 322 360 323 z2d(:,:) = puflx(:,:,1)324 DO_3D( 0, 0, 0, 0, 1, jpkm1 )325 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)326 END_3D327 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp )328 IF( cptr == 'adv' ) THEN329 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction330 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d ) ! advective salt transport in i-direction331 ENDIF332 IF( cptr == 'ldf' ) THEN333 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction334 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d ) ! diffusive salt transport in i-direction335 ENDIF336 !337 z2d(:,:) = pvflx(:,:,1)338 DO_3D( 0, 0, 0, 0, 1, jpkm1 )339 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)340 END_3D341 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp )342 IF( cptr == 'adv' ) THEN343 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction344 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d ) ! advective salt transport in j-direction345 ENDIF346 IF( cptr == 'ldf' ) THEN347 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction348 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d ) ! diffusive salt transport in j-direction349 ENDIF350 351 361 END SUBROUTINE dia_ar5_hst 352 362 … … 371 381 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 372 382 & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & 383 & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & 384 & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & 385 & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & 386 & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & 373 387 & iom_use( 'rhop' ) ) L_ar5 = .TRUE. 374 388 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DIA/diahsb.F90
r13286 r13984 267 267 IF(lwp) WRITE(numout,*) ' dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp 268 268 IF(lwp) WRITE(numout,*) 269 CALL iom_get( numror, 'frc_v', frc_v , ldxios = lrxios)270 CALL iom_get( numror, 'frc_t', frc_t , ldxios = lrxios)271 CALL iom_get( numror, 'frc_s', frc_s , ldxios = lrxios)269 CALL iom_get( numror, 'frc_v', frc_v ) 270 CALL iom_get( numror, 'frc_t', frc_t ) 271 CALL iom_get( numror, 'frc_s', frc_s ) 272 272 IF( ln_linssh ) THEN 273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t , ldxios = lrxios)274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s , ldxios = lrxios)273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) 274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 275 275 ENDIF 276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini , ldxios = lrxios) ! ice sheet coupling277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini , ldxios = lrxios)278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini , ldxios = lrxios)279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios)280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini , ldxios = lrxios)281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini , ldxios = lrxios)276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini ) ! ice sheet coupling 277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini ) 278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini ) 279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) 280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) 281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) 282 282 IF( ln_linssh ) THEN 283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lrxios)284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lrxios)283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 285 285 ENDIF 286 286 ELSE … … 323 323 IF(lwp) WRITE(numout,*) 324 324 ! 325 IF( lwxios ) CALL iom_swap( cwxios_context ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios ) 328 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios ) 325 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) 329 328 IF( ln_linssh ) THEN 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t , ldxios = lwxios)331 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s , ldxios = lwxios)329 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 332 331 ENDIF 333 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini , ldxios = lwxios) ! ice sheet coupling334 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini , ldxios = lwxios)335 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini , ldxios = lwxios)336 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini , ldxios = lwxios)337 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini , ldxios = lwxios)338 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini , ldxios = lwxios)332 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini ) ! ice sheet coupling 333 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini ) 334 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini ) 335 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) 336 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 337 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 339 338 IF( ln_linssh ) THEN 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lwxios)341 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lwxios)339 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 342 341 ENDIF 343 IF( lwxios ) CALL iom_swap( cxios_context )344 342 ! 345 343 ENDIF … … 385 383 IF( .NOT. ln_diahsb ) RETURN 386 384 387 IF(lwxios) THEN388 ! define variables in restart file when writing with XIOS389 CALL iom_set_rstw_var_active('frc_v')390 CALL iom_set_rstw_var_active('frc_t')391 CALL iom_set_rstw_var_active('frc_s')392 CALL iom_set_rstw_var_active('surf_ini')393 CALL iom_set_rstw_var_active('ssh_ini')394 CALL iom_set_rstw_var_active('e3t_ini')395 CALL iom_set_rstw_var_active('hc_loc_ini')396 CALL iom_set_rstw_var_active('sc_loc_ini')397 IF( ln_linssh ) THEN398 CALL iom_set_rstw_var_active('ssh_hc_loc_ini')399 CALL iom_set_rstw_var_active('ssh_sc_loc_ini')400 CALL iom_set_rstw_var_active('frc_wn_t')401 CALL iom_set_rstw_var_active('frc_wn_s')402 ENDIF403 ENDIF404 385 ! ------------------- ! 405 386 ! 1 - Allocate memory ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DIA/diaptr.F90
r13557 r13984 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE phycst ! physical constants 25 26 ! … … 32 33 PRIVATE 33 34 35 INTERFACE ptr_sum 36 MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 37 END INTERFACE 38 34 39 INTERFACE ptr_sj 35 40 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d … … 39 44 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 40 45 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 43 44 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals 49 50 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 51 INTEGER, PARAMETER :: jp_msk = 3 52 INTEGER, PARAMETER :: jp_vtr = 4 45 53 46 54 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 51 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 52 60 53 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d54 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d55 56 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag 57 62 58 63 !! * Substitutions 59 64 # include "do_loop_substitute.h90" … … 72 77 INTEGER , INTENT(in) :: kt ! ocean time-step index 73 78 INTEGER , INTENT(in) :: Kmm ! time level index 74 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 79 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 80 !!---------------------------------------------------------------------- 81 ! 82 IF( ln_timing ) CALL timing_start('dia_ptr') 83 84 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin 85 ! 86 IF( l_diaptr ) THEN 87 ! Calculate zonal integrals 88 IF( PRESENT( pvtr ) ) THEN 89 CALL dia_ptr_zint( Kmm, pvtr ) 90 ELSE 91 CALL dia_ptr_zint( Kmm ) 92 ENDIF 93 94 ! Calculate diagnostics only when zonal integrals have finished 95 IF( ntile == 0 .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) 96 ENDIF 97 98 IF( ln_timing ) CALL timing_stop('dia_ptr') 99 ! 100 END SUBROUTINE dia_ptr 101 102 103 SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) 104 !!---------------------------------------------------------------------- 105 !! *** ROUTINE dia_ptr_iom *** 106 !!---------------------------------------------------------------------- 107 !! ** Purpose : Calculate diagnostics and send to XIOS 108 !!---------------------------------------------------------------------- 109 INTEGER , INTENT(in) :: kt ! ocean time-step index 110 INTEGER , INTENT(in) :: Kmm ! time level index 111 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 75 112 ! 76 113 INTEGER :: ji, jj, jk, jn ! dummy loop indices 77 REAL(wp) :: zsfc,zvfc ! local scalar78 114 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 79 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace81 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace82 115 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 83 116 ! … … 90 123 !!---------------------------------------------------------------------- 91 124 ! 92 IF( ln_timing ) CALL timing_start('dia_ptr')93 94 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin95 !96 IF( .NOT. l_diaptr ) THEN97 IF( ln_timing ) CALL timing_stop('dia_ptr')98 RETURN99 ENDIF100 !101 125 ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 102 ! 126 103 127 IF( PRESENT( pvtr ) ) THEN 104 128 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 129 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 130 ! 106 131 DO jn = 1, nbasin ! by sub-basins 107 z4d1(1,:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )! zonal cumulative effective transport excluding closed seas108 DO jk = jpkm1, 1, -1 132 z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas 133 DO jk = jpkm1, 1, -1 109 134 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 110 135 END DO 111 DO ji = 1, jpi136 DO ji = 2, jpi 112 137 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 113 138 ENDDO 114 139 END DO 115 140 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 141 ! 116 142 DEALLOCATE( z4d1 ) 117 143 ENDIF 144 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 145 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 146 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 147 ! 148 DO jn = 1, nbasin 149 sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 150 r1_sjk(:,:,jn) = 0._wp 151 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 152 ! i-mean T and S, j-Stream-Function, basin 153 zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 154 zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 155 v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 156 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 157 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 158 ! 159 ENDDO 160 DO jn = 1, nbasin 161 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 162 DO ji = 2, jpi 163 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 164 ENDDO 165 ENDDO 166 CALL iom_put( 'sophtove', z3dtr ) 167 DO jn = 1, nbasin 168 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 169 DO ji = 2, jpi 170 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 171 ENDDO 172 ENDDO 173 CALL iom_put( 'sopstove', z3dtr ) 174 ! 175 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 176 ENDIF 177 178 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 179 ! Calculate barotropic heat and salt transport here 180 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 181 ! 182 DO jn = 1, nbasin 183 sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 184 r1_sjk(:,1,jn) = 0._wp 185 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 186 ! 187 zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 188 ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 189 zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 190 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 191 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 192 ! 193 ENDDO 194 DO jn = 1, nbasin 195 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 196 DO ji = 2, jpi 197 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 198 ENDDO 199 ENDDO 200 CALL iom_put( 'sophtbtr', z3dtr ) 201 DO jn = 1, nbasin 202 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 203 DO ji = 2, jpi 204 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 205 ENDDO 206 ENDDO 207 CALL iom_put( 'sopstbtr', z3dtr ) 208 ! 209 DEALLOCATE( sjk, r1_sjk ) 210 ENDIF 211 ! 212 hstr_ove(:,:,:) = 0._wp ! Zero before next timestep 213 hstr_btr(:,:,:) = 0._wp 214 pvtr_int(:,:,:,:) = 0._wp 215 ELSE 216 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 217 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 218 ! 219 DO jn = 1, nbasin 220 z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 221 DO ji = 2, jpi 222 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 223 ENDDO 224 ENDDO 225 CALL iom_put( 'zosrf', z4d1 ) 226 ! 227 DO jn = 1, nbasin 228 z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 229 DO ji = 2, jpi 230 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 231 ENDDO 232 ENDDO 233 CALL iom_put( 'zotem', z4d2 ) 234 ! 235 DO jn = 1, nbasin 236 z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 237 DO ji = 2, jpi 238 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 239 ENDDO 240 ENDDO 241 CALL iom_put( 'zosal', z4d2 ) 242 ! 243 DEALLOCATE( z4d1, z4d2 ) 244 ENDIF 245 ! 246 ! ! Advective and diffusive heat and salt transport 247 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 248 ! 249 DO jn = 1, nbasin 250 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 251 DO ji = 2, jpi 252 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 253 ENDDO 254 ENDDO 255 CALL iom_put( 'sophtadv', z3dtr ) 256 DO jn = 1, nbasin 257 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 258 DO ji = 2, jpi 259 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 260 ENDDO 261 ENDDO 262 CALL iom_put( 'sopstadv', z3dtr ) 263 ENDIF 264 ! 265 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 266 ! 267 DO jn = 1, nbasin 268 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 269 DO ji = 2, jpi 270 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 271 ENDDO 272 ENDDO 273 CALL iom_put( 'sophtldf', z3dtr ) 274 DO jn = 1, nbasin 275 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 276 DO ji = 2, jpi 277 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 278 ENDDO 279 ENDDO 280 CALL iom_put( 'sopstldf', z3dtr ) 281 ENDIF 282 ! 283 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 284 ! 285 DO jn = 1, nbasin 286 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 287 DO ji = 2, jpi 288 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 289 ENDDO 290 ENDDO 291 CALL iom_put( 'sophteiv', z3dtr ) 292 DO jn = 1, nbasin 293 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 294 DO ji = 2, jpi 295 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 296 ENDDO 297 ENDDO 298 CALL iom_put( 'sopsteiv', z3dtr ) 299 ENDIF 300 ! 301 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 302 DO jn = 1, nbasin 303 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 304 DO ji = 2, jpi 305 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 306 ENDDO 307 ENDDO 308 CALL iom_put( 'sophtvtr', z3dtr ) 309 DO jn = 1, nbasin 310 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 311 DO ji = 2, jpi 312 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 313 ENDDO 314 ENDDO 315 CALL iom_put( 'sopstvtr', z3dtr ) 316 ENDIF 317 ! 318 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 319 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 320 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 321 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 322 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 323 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) ! Revert to tile domain 324 ENDIF 325 ! 326 hstr_adv(:,:,:) = 0._wp ! Zero before next timestep 327 hstr_ldf(:,:,:) = 0._wp 328 hstr_eiv(:,:,:) = 0._wp 329 hstr_vtr(:,:,:) = 0._wp 330 pzon_int(:,:,:,:) = 0._wp 331 ENDIF 332 ! 333 DEALLOCATE( z3dtr ) 334 ! 335 END SUBROUTINE dia_ptr_iom 336 337 338 SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 339 !!---------------------------------------------------------------------- 340 !! *** ROUTINE dia_ptr_zint *** 341 !!---------------------------------------------------------------------- 342 !! ** Purpose : i and i-k sum operations on arrays 343 !! 344 !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 345 !! - Call ptr_sum to add this result to the sum over tiles 346 !! 347 !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 348 !! pzon_int - terms for i mean temperature/salinity 349 !!---------------------------------------------------------------------- 350 INTEGER , INTENT(in) :: Kmm ! time level index 351 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 352 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace 353 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace 354 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport 355 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 356 REAL(wp) :: zsfc, zvfc ! i-k surface area 357 INTEGER :: ji, jj, jk, jn ! dummy loop indices 358 !!---------------------------------------------------------------------- 359 360 IF( PRESENT( pvtr ) ) THEN 361 ! i sum of effective j transport excluding closed seas 362 IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 363 ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) ) 364 365 DO jn = 1, nbasin 366 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 367 ENDDO 368 369 CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 370 371 DEALLOCATE( v_msf ) 372 ENDIF 373 374 ! i sum of j surface area, j surface area - temperature/salinity product on V grid 118 375 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 119 376 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 120 ! define fields multiplied by scalar 377 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 378 & sjk(A1Dj(nn_hls),jpk,nbasin), & 379 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 380 121 381 zmask(:,:,:) = 0._wp 122 382 zts(:,:,:,:) = 0._wp 383 123 384 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 124 385 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 125 386 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 126 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc 387 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 127 388 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 128 389 END_3D 129 ENDIF 130 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 131 DO jn = 1, nbasin 132 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 133 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 134 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 135 r1_sjk(:,:,jn) = 0._wp 136 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 137 ! i-mean T and S, j-Stream-Function, basin 138 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 139 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 140 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 141 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 142 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 143 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 144 ! 145 ENDDO 146 DO jn = 1, nbasin 147 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 148 DO ji = 1, jpi 149 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 150 ENDDO 151 ENDDO 152 CALL iom_put( 'sophtove', z3dtr ) 153 DO jn = 1, nbasin 154 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 155 DO ji = 1, jpi 156 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 157 ENDDO 158 ENDDO 159 CALL iom_put( 'sopstove', z3dtr ) 160 ENDIF 161 162 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 163 ! Calculate barotropic heat and salt transport here 164 DO jn = 1, nbasin 165 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 166 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 167 r1_sjk(:,1,jn) = 0._wp 168 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 169 ! 170 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 171 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 172 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 173 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 174 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 175 DEALLOCATE( sjk, r1_sjk ) 176 ! 177 ENDDO 178 DO jn = 1, nbasin 179 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 180 DO ji = 1, jpi 181 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 182 ENDDO 183 ENDDO 184 CALL iom_put( 'sophtbtr', z3dtr ) 185 DO jn = 1, nbasin 186 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 187 DO ji = 1, jpi 188 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 189 ENDDO 190 ENDDO 191 CALL iom_put( 'sopstbtr', z3dtr ) 192 ENDIF 193 ! 390 391 DO jn = 1, nbasin 392 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 393 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 394 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 395 ENDDO 396 397 CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) 398 CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 399 CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 400 401 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 402 ENDIF 194 403 ELSE 195 ! 196 zmask(:,:,:) = 0._wp 197 zts(:,:,:,:) = 0._wp 198 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 199 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 404 ! i sum of j surface area - temperature/salinity product on T grid 405 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN 406 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 407 & sjk(A1Dj(nn_hls),jpk,nbasin), & 408 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 409 410 zmask(:,:,:) = 0._wp 411 zts(:,:,:,:) = 0._wp 412 200 413 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 201 414 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) … … 204 417 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 205 418 END_3D 206 ! 207 DO jn = 1, nbasin 208 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 209 DO ji = 1, jpi 210 zmask(ji,:,:) = zmask(1,:,:) 211 ENDDO 212 z4d1(:,:,:,jn) = zmask(:,:,:) 213 ENDDO 214 CALL iom_put( 'zosrf', z4d1 ) 215 ! 216 DO jn = 1, nbasin 217 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 218 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 219 DO ji = 1, jpi 220 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 221 ENDDO 222 ENDDO 223 CALL iom_put( 'zotem', z4d2 ) 224 ! 225 DO jn = 1, nbasin 226 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 227 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 228 DO ji = 1, jpi 229 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 230 ENDDO 231 ENDDO 232 CALL iom_put( 'zosal', z4d2 ) 233 DEALLOCATE( z4d1, z4d2 ) 234 ! 235 ENDIF 236 ! 237 ! ! Advective and diffusive heat and salt transport 238 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 239 ! 240 DO jn = 1, nbasin 241 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 242 DO ji = 1, jpi 243 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 244 ENDDO 245 ENDDO 246 CALL iom_put( 'sophtadv', z3dtr ) 247 DO jn = 1, nbasin 248 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 249 DO ji = 1, jpi 250 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 251 ENDDO 252 ENDDO 253 CALL iom_put( 'sopstadv', z3dtr ) 254 ENDIF 255 ! 256 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 257 ! 258 DO jn = 1, nbasin 259 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 260 DO ji = 1, jpi 261 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 262 ENDDO 263 ENDDO 264 CALL iom_put( 'sophtldf', z3dtr ) 265 DO jn = 1, nbasin 266 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 267 DO ji = 1, jpi 268 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 269 ENDDO 270 ENDDO 271 CALL iom_put( 'sopstldf', z3dtr ) 272 ENDIF 273 ! 274 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 275 ! 276 DO jn = 1, nbasin 277 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 278 DO ji = 1, jpi 279 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 280 ENDDO 281 ENDDO 282 CALL iom_put( 'sophteiv', z3dtr ) 283 DO jn = 1, nbasin 284 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 285 DO ji = 1, jpi 286 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 287 ENDDO 288 ENDDO 289 CALL iom_put( 'sopsteiv', z3dtr ) 290 ENDIF 291 ! 419 420 DO jn = 1, nbasin 421 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 422 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 423 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 424 ENDDO 425 426 CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) 427 CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 428 CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 429 430 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 431 ENDIF 432 433 ! i-k sum of j surface area - temperature/salinity product on V grid 292 434 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 435 ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 436 293 437 zts(:,:,:,:) = 0._wp 438 294 439 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 295 440 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 297 442 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 298 443 END_3D 299 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 300 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 301 DO jn = 1, nbasin 302 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 303 DO ji = 1, jpi 304 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 305 ENDDO 306 ENDDO 307 CALL iom_put( 'sophtvtr', z3dtr ) 308 DO jn = 1, nbasin 309 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 310 DO ji = 1, jpi 311 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 312 ENDDO 313 ENDDO 314 CALL iom_put( 'sopstvtr', z3dtr ) 315 ENDIF 316 ! 317 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 318 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 319 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 320 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 321 ENDIF 322 ! 444 445 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 446 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 447 448 DEALLOCATE( zts ) 449 ENDIF 323 450 ENDIF 324 ! 325 DEALLOCATE( z3dtr ) 326 ! 327 IF( ln_timing ) CALL timing_stop('dia_ptr') 328 ! 329 END SUBROUTINE dia_ptr 451 END SUBROUTINE dia_ptr_zint 330 452 331 453 … … 340 462 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 341 463 !!---------------------------------------------------------------------- 342 464 343 465 ! l_diaptr is defined with iom_use 344 466 ! --> dia_ptr_init must be done after the call to iom_init … … 347 469 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 348 470 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 349 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 471 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 350 472 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 351 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 352 473 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 474 353 475 IF(lwp) THEN ! Control print 354 476 WRITE(numout,*) … … 398 520 hstr_btr(:,:,:) = 0._wp ! 399 521 hstr_vtr(:,:,:) = 0._wp ! 522 pvtr_int(:,:,:,:) = 0._wp 523 pzon_int(:,:,:,:) = 0._wp 400 524 ! 401 525 ll_init = .FALSE. … … 415 539 INTEGER , INTENT(in ) :: ktra ! tracer index 416 540 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 417 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 541 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion 542 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! 418 543 INTEGER :: jn ! 419 544 545 DO jn = 1, nbasin 546 zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 547 ENDDO 420 548 ! 421 549 IF( cptr == 'adv' ) THEN 422 IF( ktra == jp_tem ) THEN 423 DO jn = 1, nbasin 424 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 425 ENDDO 426 ENDIF 427 IF( ktra == jp_sal ) THEN 428 DO jn = 1, nbasin 429 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 430 ENDDO 431 ENDIF 550 IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 551 IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 552 ELSE IF( cptr == 'ldf' ) THEN 553 IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 554 IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 555 ELSE IF( cptr == 'eiv' ) THEN 556 IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 557 IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 558 ELSE IF( cptr == 'vtr' ) THEN 559 IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 560 IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 432 561 ENDIF 433 562 ! 434 IF( cptr == 'ldf' ) THEN 435 IF( ktra == jp_tem ) THEN 436 DO jn = 1, nbasin 437 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 438 ENDDO 439 ENDIF 440 IF( ktra == jp_sal ) THEN 441 DO jn = 1, nbasin 442 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 443 ENDDO 444 ENDIF 563 END SUBROUTINE dia_ptr_hst 564 565 566 SUBROUTINE ptr_sum_2d( phstr, pva ) 567 !!---------------------------------------------------------------------- 568 !! *** ROUTINE ptr_sum_2d *** 569 !!---------------------------------------------------------------------- 570 !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions 571 !! 572 !! ** Method : - phstr = phstr + pva 573 !! - Call mpp_sum if the final tile 574 !! 575 !! ** Action : phstr 576 !!---------------------------------------------------------------------- 577 REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! 578 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! 579 INTEGER :: jj 580 #if defined key_mpp_mpi 581 INTEGER, DIMENSION(1) :: ish1d 582 INTEGER, DIMENSION(2) :: ish2d 583 REAL(wp), DIMENSION(jpj*nbasin) :: zwork 584 #endif 585 586 DO jj = ntsj, ntej 587 phstr(jj,:) = phstr(jj,:) + pva(jj,:) 588 END DO 589 590 #if defined key_mpp_mpi 591 IF( ntile == 0 .OR. ntile == nijtile ) THEN 592 ish1d(1) = jpj*nbasin 593 ish2d(1) = jpj ; ish2d(2) = nbasin 594 zwork(:) = RESHAPE( phstr(:,:), ish1d ) 595 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 596 phstr(:,:) = RESHAPE( zwork, ish2d ) 445 597 ENDIF 446 ! 447 IF( cptr == 'eiv' ) THEN 448 IF( ktra == jp_tem ) THEN 449 DO jn = 1, nbasin 450 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 451 ENDDO 452 ENDIF 453 IF( ktra == jp_sal ) THEN 454 DO jn = 1, nbasin 455 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 456 ENDDO 457 ENDIF 598 #endif 599 END SUBROUTINE ptr_sum_2d 600 601 602 SUBROUTINE ptr_sum_3d( phstr, pva ) 603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE ptr_sum_3d *** 605 !!---------------------------------------------------------------------- 606 !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions 607 !! 608 !! ** Method : - phstr = phstr + pva 609 !! - Call mpp_sum if the final tile 610 !! 611 !! ** Action : phstr 612 !!---------------------------------------------------------------------- 613 REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! 614 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! 615 INTEGER :: jj, jk 616 #if defined key_mpp_mpi 617 INTEGER, DIMENSION(1) :: ish1d 618 INTEGER, DIMENSION(3) :: ish3d 619 REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork 620 #endif 621 622 DO jk = 1, jpk 623 DO jj = ntsj, ntej 624 phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) 625 END DO 626 END DO 627 628 #if defined key_mpp_mpi 629 IF( ntile == 0 .OR. ntile == nijtile ) THEN 630 ish1d(1) = jpj*jpk*nbasin 631 ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin 632 zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 633 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 634 phstr(:,:,:) = RESHAPE( zwork, ish3d ) 458 635 ENDIF 459 ! 460 IF( cptr == 'vtr' ) THEN 461 IF( ktra == jp_tem ) THEN 462 DO jn = 1, nbasin 463 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 464 ENDDO 465 ENDIF 466 IF( ktra == jp_sal ) THEN 467 DO jn = 1, nbasin 468 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 469 ENDDO 470 ENDIF 471 ENDIF 472 ! 473 END SUBROUTINE dia_ptr_hst 636 #endif 637 END SUBROUTINE ptr_sum_3d 474 638 475 639 … … 479 643 !!---------------------------------------------------------------------- 480 644 INTEGER :: dia_ptr_alloc ! return value 481 INTEGER, DIMENSION( 3) :: ierr645 INTEGER, DIMENSION(2) :: ierr 482 646 !!---------------------------------------------------------------------- 483 647 ierr(:) = 0 … … 491 655 & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) 492 656 ! 493 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 657 ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & 658 & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) 494 659 ! 495 660 dia_ptr_alloc = MAXVAL( ierr ) … … 511 676 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 512 677 !!---------------------------------------------------------------------- 513 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: pvflx ! mask flux array at V-point514 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) 678 REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point 679 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 515 680 ! 516 681 INTEGER :: ji, jj, jk ! dummy loop arguments 517 INTEGER :: ijpj ! ??? 518 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 682 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 519 683 !!-------------------------------------------------------------------- 520 684 ! 521 p_fval => p_fval1d522 523 ijpj = jpj524 685 p_fval(:) = 0._wp 525 686 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 526 687 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 527 688 END_3D 528 #if defined key_mpp_mpi529 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)530 #endif531 !532 689 END FUNCTION ptr_sj_3d 533 690 … … 544 701 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 545 702 !!---------------------------------------------------------------------- 546 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj):: pvflx ! mask flux array at V-point703 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pvflx ! mask flux array at V-point 547 704 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 548 705 ! 549 706 INTEGER :: ji,jj ! dummy loop arguments 550 INTEGER :: ijpj ! ??? 551 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 707 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 552 708 !!-------------------------------------------------------------------- 553 ! 554 p_fval => p_fval1d 555 556 ijpj = jpj 709 ! 557 710 p_fval(:) = 0._wp 558 711 DO_2D( 0, 0, 0, 0 ) 559 712 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 560 713 END_2D 561 #if defined key_mpp_mpi562 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )563 #endif564 !565 714 END FUNCTION ptr_sj_2d 566 715 … … 588 737 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 589 738 END_2D 590 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )591 739 END DO 592 740 ! … … 607 755 !! 608 756 IMPLICIT none 609 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj,jpk) :: pta ! mask flux array at V-point610 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) 757 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point 758 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 611 759 !! 612 760 INTEGER :: ji, jj, jk ! dummy loop arguments 613 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 614 #if defined key_mpp_mpi 615 INTEGER, DIMENSION(1) :: ish 616 INTEGER, DIMENSION(2) :: ish2 617 INTEGER :: ijpjjpk 618 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 619 #endif 761 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value 620 762 !!-------------------------------------------------------------------- 621 763 ! 622 p_fval => p_fval2d623 624 764 p_fval(:,:) = 0._wp 625 765 ! … … 627 767 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 628 768 END_3D 629 !630 #if defined key_mpp_mpi631 ijpjjpk = jpj*jpk632 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk633 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )634 CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )635 p_fval(:,:) = RESHAPE( zwork, ish2 )636 #endif637 !638 769 END FUNCTION ptr_sjk 639 770 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/daymod.F90
r13558 r13984 149 149 CALL day( nit000 ) 150 150 ! 151 IF( lwxios ) THEN152 ! define variables in restart file when writing with XIOS153 CALL iom_set_rstw_var_active('kt')154 CALL iom_set_rstw_var_active('ndastp')155 CALL iom_set_rstw_var_active('adatrj')156 CALL iom_set_rstw_var_active('ntime')157 ENDIF158 159 151 END SUBROUTINE day_init 160 152 … … 324 316 325 317 IF( TRIM(cdrw) == 'READ' ) THEN 326 327 318 IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN 328 319 ! Get Calendar informations 329 CALL iom_get( numror, 'kt', zkt , ldxios = lrxios) ! last time-step of previous run320 CALL iom_get( numror, 'kt', zkt ) ! last time-step of previous run 330 321 IF(lwp) THEN 331 322 WRITE(numout,*) ' *** Info read in restart : ' … … 346 337 IF ( nrstdt == 2 ) THEN 347 338 ! read the parameters corresponding to nit000 - 1 (last time step of previous run) 348 CALL iom_get( numror, 'ndastp', zndastp , ldxios = lrxios)339 CALL iom_get( numror, 'ndastp', zndastp ) 349 340 ndastp = NINT( zndastp ) 350 CALL iom_get( numror, 'adatrj', adatrj , ldxios = lrxios)351 CALL iom_get( numror, 'ntime' , ktime , ldxios = lrxios)341 CALL iom_get( numror, 'adatrj', adatrj ) 342 CALL iom_get( numror, 'ntime' , ktime ) 352 343 nn_time0 = NINT(ktime) 353 344 ! calculate start time in hours and minutes … … 410 401 ENDIF 411 402 ! calendar control 412 IF( lwxios ) CALL iom_swap( cwxios_context ) 413 CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) , ldxios = lwxios ) ! time-step 414 CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) , ldxios = lwxios ) ! date 415 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj , ldxios = lwxios ) ! number of elapsed days since 403 CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) ) ! time-step 404 CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) ) ! date 405 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since 416 406 ! ! the begining of the run [s] 417 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp), ldxios = lwxios ) ! time 418 IF( lwxios ) CALL iom_swap( cxios_context ) 407 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time 419 408 ENDIF 420 409 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/dom_oce.F90
r13557 r13984 74 74 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 75 75 76 ! Tiling namelist 77 LOGICAL, PUBLIC :: ln_tile 78 INTEGER :: nn_ltile_i, nn_ltile_j 79 80 ! Domain tiling (all tiles) 81 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain 82 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsj_a ! 83 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain 84 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntej_a ! 85 76 86 ! !: domain MPP decomposition parameters 77 87 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom … … 87 97 INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in 88 98 INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions 99 INTEGER, PUBLIC :: nones, nonws !: north-east, north-west directions for sending 100 INTEGER, PUBLIC :: noses, nosws !: south-east, south-west directions for sending 101 INTEGER, PUBLIC :: noner, nonwr !: north-east, north-west directions for receiving 102 INTEGER, PUBLIC :: noser, noswr !: south-east, south-west directions for receiving 89 103 INTEGER, PUBLIC :: nidom !: ??? 90 104 … … 296 310 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & 297 311 & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) ) 298 #endif 312 #endif 299 313 ! 300 314 ii = ii+1 301 315 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 302 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 316 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 303 317 ! 304 318 ii = ii+1 … … 317 331 ! 318 332 ii = ii+1 319 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 333 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 320 334 ! 321 335 ii = ii+1 … … 323 337 ! 324 338 ii = ii+1 325 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 339 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 326 340 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 327 341 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) ) … … 331 345 ! 332 346 ii = ii+1 333 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 347 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 334 348 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 335 349 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/domain.F90
r13558 r13984 45 45 USE closea , ONLY : dom_clo ! closed seas 46 46 ! 47 USE prtctl ! Print control (prt_ctl_info routine) 47 48 USE in_out_manager ! I/O manager 48 49 USE iom ! I/O library … … 55 56 PUBLIC dom_init ! called by nemogcm.F90 56 57 PUBLIC domain_cfg ! called by nemogcm.F90 58 PUBLIC dom_tile ! called by step.F90 57 59 58 60 !!------------------------------------------------------------------------- … … 63 65 CONTAINS 64 66 65 SUBROUTINE dom_init( Kbb, Kmm, Kaa , cdstr)67 SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 66 68 !!---------------------------------------------------------------------- 67 69 !! *** ROUTINE dom_init *** … … 79 81 !!---------------------------------------------------------------------- 80 82 INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 81 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables82 83 ! 83 84 INTEGER :: ji, jj, jk, jt ! dummy loop indices … … 120 121 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 121 122 ENDIF 123 nn_wxios = 0 124 ln_xios_read = .FALSE. 122 125 ! 123 126 ! !== Reference coordinate system ==! 124 127 ! 125 CALL dom_glo ! global domain versus local domain 126 CALL dom_nam ! read namelist ( namrun, namdom ) 127 ! 128 IF( lwxios ) THEN 129 !define names for restart write and set core output (restart.F90) 130 CALL iom_set_rst_vars(rst_wfields) 131 CALL iom_set_rstw_core(cdstr) 132 ENDIF 133 !reset namelist for SAS 134 IF(cdstr == 'SAS') THEN 135 IF(lrxios) THEN 136 IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' 137 lrxios = .FALSE. 138 ENDIF 139 ENDIF 128 CALL dom_glo ! global domain versus local domain 129 CALL dom_nam ! read namelist ( namrun, namdom ) 130 CALL dom_tile( ntsi, ntsj, ntei, ntej ) ! Tile domain 131 140 132 ! 141 133 CALL dom_hgr ! Horizontal mesh … … 285 277 286 278 279 SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile ) 280 !!---------------------------------------------------------------------- 281 !! *** ROUTINE dom_tile *** 282 !! 283 !! ** Purpose : Set tile domain variables 284 !! 285 !! ** Action : - ktsi, ktsj : start of internal part of domain 286 !! - ktei, ktej : end of internal part of domain 287 !! - ntile : current tile number 288 !! - nijtile : total number of tiles 289 !!---------------------------------------------------------------------- 290 INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej ! Tile domain indices 291 INTEGER, INTENT(in), OPTIONAL :: ktile ! Tile number 292 INTEGER :: jt ! dummy loop argument 293 INTEGER :: iitile, ijtile ! Local integers 294 CHARACTER (len=11) :: charout 295 !!---------------------------------------------------------------------- 296 IF( PRESENT(ktile) .AND. ln_tile ) THEN 297 ntile = ktile ! Set domain indices for tile 298 ktsi = ntsi_a(ktile) 299 ktsj = ntsj_a(ktile) 300 ktei = ntei_a(ktile) 301 ktej = ntej_a(ktile) 302 303 IF(sn_cfctl%l_prtctl) THEN 304 WRITE(charout, FMT="('ntile =', I4)") ktile 305 CALL prt_ctl_info( charout ) 306 ENDIF 307 ELSE 308 ntile = 0 ! Initialise to full domain 309 nijtile = 1 310 ktsi = Nis0 311 ktsj = Njs0 312 ktei = Nie0 313 ktej = Nje0 314 315 IF( ln_tile ) THEN ! Calculate tile domain indices 316 iitile = Ni_0 / nn_ltile_i ! Number of tiles 317 ijtile = Nj_0 / nn_ltile_j 318 IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 319 IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 320 321 nijtile = iitile * ijtile 322 ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile) ) 323 324 ntsi_a(0) = ktsi ! Full domain 325 ntsj_a(0) = ktsj 326 ntei_a(0) = ktei 327 ntej_a(0) = ktej 328 329 DO jt = 1, nijtile ! Tile domains 330 ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) 331 ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) 332 ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) 333 ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) 334 ENDDO 335 ENDIF 336 337 IF(lwp) THEN ! control print 338 WRITE(numout,*) 339 WRITE(numout,*) 'dom_tile : Domain tiling decomposition' 340 WRITE(numout,*) '~~~~~~~~' 341 IF( ln_tile ) THEN 342 WRITE(numout,*) iitile, 'tiles in i' 343 WRITE(numout,*) ' Starting indices' 344 WRITE(numout,*) ' ', (ntsi_a(jt), jt=1, iitile) 345 WRITE(numout,*) ' Ending indices' 346 WRITE(numout,*) ' ', (ntei_a(jt), jt=1, iitile) 347 WRITE(numout,*) ijtile, 'tiles in j' 348 WRITE(numout,*) ' Starting indices' 349 WRITE(numout,*) ' ', (ntsj_a(jt), jt=1, nijtile, iitile) 350 WRITE(numout,*) ' Ending indices' 351 WRITE(numout,*) ' ', (ntej_a(jt), jt=1, nijtile, iitile) 352 ELSE 353 WRITE(numout,*) 'No domain tiling' 354 WRITE(numout,*) ' i indices =', ktsi, ':', ktei 355 WRITE(numout,*) ' j indices =', ktsj, ':', ktej 356 ENDIF 357 ENDIF 358 ENDIF 359 END SUBROUTINE dom_tile 360 361 287 362 SUBROUTINE dom_nam 288 363 !!---------------------------------------------------------------------- … … 293 368 !! ** input : - namrun namelist 294 369 !! - namdom namelist 370 !! - namtile namelist 295 371 !! - namnc4 namelist ! "key_netcdf4" only 296 372 !!---------------------------------------------------------------------- … … 305 381 & ln_cfmeta, ln_xios_read, nn_wxios 306 382 NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 383 NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 307 384 #if defined key_netcdf4 308 385 NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip … … 441 518 r1_Dt = 1._wp / rDt 442 519 520 READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 521 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) 522 READ ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) 523 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtile in configuration namelist' ) 524 IF(lwm) WRITE( numond, namtile ) 525 526 IF(lwp) THEN 527 WRITE(numout,*) 528 WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition' 529 WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile 530 WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i 531 WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j 532 WRITE(numout,*) 533 IF( ln_tile ) THEN 534 WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j 535 ELSE 536 WRITE(numout,*) ' Domain tiling will NOT be used' 537 ENDIF 538 ENDIF 539 443 540 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 444 541 lrxios = ln_xios_read.AND.ln_rstart -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/domqco.F90
r13295 r13984 91 91 ! 92 92 CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 93 !94 ! IF(lwxios) THEN ! define variables in restart file when writing with XIOS95 ! CALL iom_set_rstw_var_active('e3t_b')96 ! CALL iom_set_rstw_var_active('e3t_n')97 ! ENDIF98 93 ! 99 94 END SUBROUTINE dom_qco_init … … 217 212 ! 218 213 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 219 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) , ldxios = lrxios)220 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)214 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) ) 215 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 221 216 ! needed to restart if land processor not computed 222 217 IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' … … 232 227 IF(lwp) write(numout,*) 'sshn set equal to sshb.' 233 228 IF(lwp) write(numout,*) 'neuler is forced to 0' 234 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) , ldxios = lrxios)229 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 235 230 ssh(:,:,Kmm) = ssh(:,:,Kbb) 236 231 l_1st_euler = .TRUE. … … 239 234 IF(lwp) write(numout,*) 'sshb set equal to sshn.' 240 235 IF(lwp) write(numout,*) 'neuler is forced to 0' 241 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) , ldxios = lrxios)236 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 242 237 ssh(:,:,Kbb) = ssh(:,:,Kmm) 243 238 l_1st_euler = .TRUE. -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/domutl.F90
r13458 r13984 21 21 PRIVATE 22 22 23 INTERFACE is_tile 24 MODULE PROCEDURE is_tile_2d, is_tile_3d, is_tile_4d 25 END INTERFACE is_tile 26 23 27 PUBLIC dom_ngb ! routine called in iom.F90 module 24 28 PUBLIC dom_uniq ! Called by dommsk and domwri 29 PUBLIC is_tile 25 30 26 31 !!---------------------------------------------------------------------- … … 109 114 ! 110 115 END SUBROUTINE dom_uniq 111 116 117 118 FUNCTION is_tile_2d( pt ) 119 !! 120 REAL(wp), DIMENSION(:,:), INTENT(in) :: pt 121 INTEGER :: is_tile_2d 122 !! 123 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 124 is_tile_2d = 1 125 ELSE 126 is_tile_2d = 0 127 ENDIF 128 END FUNCTION is_tile_2d 129 130 131 FUNCTION is_tile_3d( pt ) 132 !! 133 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pt 134 INTEGER :: is_tile_3d 135 !! 136 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 137 is_tile_3d = 1 138 ELSE 139 is_tile_3d = 0 140 ENDIF 141 END FUNCTION is_tile_3d 142 143 144 FUNCTION is_tile_4d( pt ) 145 !! 146 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pt 147 INTEGER :: is_tile_4d 148 !! 149 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 150 is_tile_4d = 1 151 ELSE 152 is_tile_4d = 0 153 ENDIF 154 END FUNCTION is_tile_4d 155 112 156 !!====================================================================== 113 157 END MODULE domutl -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/domvvl.F90
r13497 r13984 282 282 ENDIF 283 283 ! 284 IF(lwxios) THEN285 ! define variables in restart file when writing with XIOS286 CALL iom_set_rstw_var_active('e3t_b')287 CALL iom_set_rstw_var_active('e3t_n')288 ! ! ----------------------- !289 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !290 ! ! ----------------------- !291 CALL iom_set_rstw_var_active('tilde_e3t_b')292 CALL iom_set_rstw_var_active('tilde_e3t_n')293 END IF294 ! ! -------------!295 IF( ln_vvl_ztilde ) THEN ! z_tilde case !296 ! ! ------------ !297 CALL iom_set_rstw_var_active('hdiv_lf')298 ENDIF299 !300 ENDIF301 !302 284 END SUBROUTINE dom_vvl_zgr 303 285 … … 440 422 ! (stored for tracer advction and continuity equation) 441 423 CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 442 443 424 ! 4 - Time stepping of baroclinic scale factors 444 425 ! --------------------------------------------- … … 803 784 IF( ln_rstart ) THEN !* Read the restart file 804 785 CALL rst_read_open ! open the restart file if necessary 805 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)786 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 806 787 ! 807 788 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 816 797 ! 817 798 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 818 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)819 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)799 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 800 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 820 801 ! needed to restart if land processor not computed 821 802 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 831 812 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 832 813 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 833 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)814 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 834 815 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 835 816 l_1st_euler = .true. … … 838 819 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 839 820 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 840 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)821 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 841 822 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 842 823 l_1st_euler = .true. … … 863 844 ! ! ----------------------- ! 864 845 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 865 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)866 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)846 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 847 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 867 848 ELSE ! one at least array is missing 868 849 tilde_e3t_b(:,:,:) = 0.0_wp … … 873 854 ! ! ------------ ! 874 855 IF( id5 > 0 ) THEN ! required array exists 875 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)856 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 876 857 ELSE ! array is missing 877 858 hdiv_lf(:,:,:) = 0.0_wp … … 946 927 ! ! =================== 947 928 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 948 IF( lwxios ) CALL iom_swap( cwxios_context )949 929 ! ! --------- ! 950 930 ! ! all cases ! 951 931 ! ! --------- ! 952 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)953 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)932 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 933 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 954 934 ! ! ----------------------- ! 955 935 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 956 936 ! ! ----------------------- ! 957 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)958 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)937 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 938 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 959 939 END IF 960 940 ! ! -------------! 961 941 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 962 942 ! ! ------------ ! 963 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)943 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 964 944 ENDIF 965 945 ! 966 IF( lwxios ) CALL iom_swap( cxios_context )967 946 ENDIF 968 947 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DOM/dtatsd.F90
r13497 r13984 18 18 USE phycst ! physical constants 19 19 USE dom_oce ! ocean space and time domain 20 USE domain, ONLY : dom_tile 20 21 USE fldread ! read input fields 21 22 ! … … 135 136 !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt 136 137 !!---------------------------------------------------------------------- 137 INTEGER 138 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts), INTENT( out) :: ptsd ! T & S data138 INTEGER , INTENT(in ) :: kt ! ocean time-step 139 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data 139 140 ! 140 141 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 141 142 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 143 INTEGER :: itile 142 144 REAL(wp):: zl, zi ! local scalars 143 145 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace 144 146 !!---------------------------------------------------------------------- 145 147 ! 146 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 149 itile = ntile 150 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 151 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! 147 152 ! 148 153 ! 149 154 !!gm This should be removed from the code ===>>>> T & S files has to be changed 150 ! 151 ! !== ORCA_R2 configuration and T & S damping ==! 152 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 153 IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations 154 ! 155 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 156 ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 157 DO jj = mj0(ij0), mj1(ij1) 158 DO ji = mi0(ii0), mi1(ii1) 159 sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 160 sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 161 sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 162 ! 163 sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 164 sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 165 sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 166 sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 155 ! 156 ! !== ORCA_R2 configuration and T & S damping ==! 157 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 158 IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations 159 ! 160 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 161 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 172 END DO 167 173 END DO 168 END DO 169 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 170 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 171 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp 172 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 173 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 174 ENDIF 175 ENDIF 174 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 175 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 176 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp 177 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 178 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 179 ENDIF 180 ENDIF 176 181 !!gm end 177 ! 178 ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:) ! NO mask 179 ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:) 182 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 183 ENDIF 184 ! 185 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 186 ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask 187 ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) 188 END_3D 180 189 ! 181 190 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! 182 191 ! 183 IF( kt == nit000 .AND. lwp )THEN 184 WRITE(numout,*) 185 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 186 ENDIF 187 ! 188 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 192 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 193 IF( kt == nit000 .AND. lwp )THEN 194 WRITE(numout,*) 195 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 196 ENDIF 197 ENDIF 198 ! 199 ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case, but did not work in the zco case 200 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S 189 201 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 202 zl = gdept_0(ji,jj,jk) … … 215 227 ELSE !== z- or zps- coordinate ==! 216 228 ! 217 ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:) ! Mask 218 ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) 229 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 230 ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! Mask 231 ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 232 END_3D 219 233 ! 220 234 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 221 DO_2D( 1, 1, 1, 1 ) 235 ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case 236 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 237 ik = mbkt(ji,jj) 223 238 IF( ik > 1 ) THEN -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DYN/dynhpg.F90
r13295 r13984 302 302 INTEGER :: iku, ikv ! temporary integers 303 303 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 304 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 305 REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 304 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 305 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zgtsu, zgtsv 306 REAL(wp), DIMENSION(jpi,jpj) :: zgru, zgrv 306 307 !!---------------------------------------------------------------------- 307 308 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/DYN/dynspg_ts.F90
r13546 r13984 900 900 ! ! --------------- 901 901 IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN !* Read the restart file 902 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)903 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)904 CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)905 CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)902 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp ) 903 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp ) 904 CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp ) 905 CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp ) 906 906 IF( .NOT.ln_bt_av ) THEN 907 CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp , ldxios = lrxios)908 CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)909 CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)910 CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp , ldxios = lrxios)911 CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)912 CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)907 CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp ) 908 CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp ) 909 CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp ) 910 CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp ) 911 CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp ) 912 CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp ) 913 913 ENDIF 914 914 #if defined key_agrif 915 915 ! Read time integrated fluxes 916 916 IF ( .NOT.Agrif_Root() ) THEN 917 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)918 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)917 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp ) 918 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp ) 919 919 ELSE 920 920 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif … … 935 935 ! ! ------------------- 936 936 IF(lwp) WRITE(numout,*) '---- ts_rst ----' 937 IF( lwxios ) CALL iom_swap( cwxios_context ) 938 CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:), ldxios = lwxios ) 939 CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:), ldxios = lwxios ) 940 CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:), ldxios = lwxios ) 941 CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:), ldxios = lwxios ) 937 CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:) ) 938 CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:) ) 939 CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:) ) 940 CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:) ) 942 941 ! 943 942 IF (.NOT.ln_bt_av) THEN 944 CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) , ldxios = lwxios)945 CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) , ldxios = lwxios)946 CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) , ldxios = lwxios)947 CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) , ldxios = lwxios)948 CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) , ldxios = lwxios)949 CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) , ldxios = lwxios)943 CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) ) 944 CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) ) 945 CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) ) 946 CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) ) 947 CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) ) 948 CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) ) 950 949 ENDIF 951 950 #if defined key_agrif 952 951 ! Save time integrated fluxes 953 952 IF ( .NOT.Agrif_Root() ) THEN 954 CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:) , ldxios = lwxios)955 CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:) , ldxios = lwxios)953 CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:) ) 954 CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:) ) 956 955 ENDIF 957 956 #endif 958 IF( lwxios ) CALL iom_swap( cxios_context )959 957 ENDIF 960 958 ! … … 1048 1046 ! ! read restart when needed 1049 1047 CALL ts_rst( nit000, 'READ' ) 1050 !1051 IF( lwxios ) THEN1052 ! define variables in restart file when writing with XIOS1053 CALL iom_set_rstw_var_active('ub2_b')1054 CALL iom_set_rstw_var_active('vb2_b')1055 CALL iom_set_rstw_var_active('un_bf')1056 CALL iom_set_rstw_var_active('vn_bf')1057 !1058 IF (.NOT.ln_bt_av) THEN1059 CALL iom_set_rstw_var_active('sshbb_e')1060 CALL iom_set_rstw_var_active('ubb_e')1061 CALL iom_set_rstw_var_active('vbb_e')1062 CALL iom_set_rstw_var_active('sshb_e')1063 CALL iom_set_rstw_var_active('ub_e')1064 CALL iom_set_rstw_var_active('vb_e')1065 ENDIF1066 #if defined key_agrif1067 ! Save time integrated fluxes1068 IF ( .NOT.Agrif_Root() ) THEN1069 CALL iom_set_rstw_var_active('ub2_i_b')1070 CALL iom_set_rstw_var_active('vb2_i_b')1071 ENDIF1072 #endif1073 ENDIF1074 1048 ! 1075 1049 END SUBROUTINE dyn_spg_ts_init -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/in_out_manager.F90
r13286 r13984 89 89 LOGICAL :: lrst_abl !: logical to control the abl restart write 90 90 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 91 INTEGER :: numrir !: logical unit for ice restart (read) 92 INTEGER :: numrar !: logical unit for abl restart (read) 93 INTEGER :: numrow !: logical unit for ocean restart (write) 94 INTEGER :: numriw !: logical unit for ice restart (write) 95 INTEGER :: numraw !: logical unit for abl restart (write) 91 INTEGER :: numrir = 0 !: logical unit for ice restart (read) 92 INTEGER :: numrar = 0 !: logical unit for abl restart (read) 93 INTEGER :: numrow = 0 !: logical unit for ocean restart (write) 94 INTEGER :: numriw = 0 !: logical unit for ice restart (write) 95 INTEGER :: numraw = 0 !: logical unit for abl restart (write) 96 INTEGER :: numrtr = 0 !: trc restart (read ) 97 INTEGER :: numrtw = 0 !: trc restart (write ) 98 INTEGER :: numrsr = 0 !: logical unit for sed restart (read) 99 INTEGER :: numrsw = 0 !: logical unit for sed restart (write) 100 96 101 INTEGER :: nrst_lst !: number of restart to output next 97 102 … … 165 170 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T 166 171 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area 167 CHARACTER(lc) :: cxios_context !: context name used in xios 168 CHARACTER(lc) :: crxios_context !: context name used in xios to read restart 169 CHARACTER(lc) :: cwxios_context !: context name used in xios to write restart file 172 CHARACTER(LEN=lc) :: cxios_context !: context name used in xios 173 CHARACTER(LEN=lc) :: cr_ocerst_cxt !: context name used in xios to read OCE restart 174 CHARACTER(LEN=lc) :: cw_ocerst_cxt !: context name used in xios to write OCE restart file 175 CHARACTER(LEN=lc) :: cr_icerst_cxt !: context name used in xios to read SI3 restart 176 CHARACTER(LEN=lc) :: cw_icerst_cxt !: context name used in xios to write SI3 restart file 177 CHARACTER(LEN=lc) :: cr_toprst_cxt !: context name used in xios to read TOP restart 178 CHARACTER(LEN=lc) :: cw_toprst_cxt !: context name used in xios to write TOP restart file 179 CHARACTER(LEN=lc) :: cr_sedrst_cxt !: context name used in xios to read SEDIMENT restart 180 CHARACTER(LEN=lc) :: cw_sedrst_cxt !: context name used in xios to write SEDIMENT restart file 181 182 183 170 184 171 185 !! * Substitutions -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/iom.F90
r13747 r13984 46 46 USE lib_fortran 47 47 USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal 48 USE iom_nf90 49 USE netcdf 48 50 49 51 IMPLICIT NONE … … 58 60 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 59 61 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 62 PUBLIC iom_xios_setid 60 63 61 64 PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp … … 69 72 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 70 73 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate 71 PRIVATE iom_set_rst_context, iom_set_ rstw_active, iom_set_rstr_active74 PRIVATE iom_set_rst_context, iom_set_vars_active 72 75 # endif 73 PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars 76 PRIVATE set_xios_context 77 PRIVATE iom_set_rstw_active 74 78 75 79 INTERFACE iom_get … … 101 105 CONTAINS 102 106 103 SUBROUTINE iom_init( cdname, fname, ld_closedef )107 SUBROUTINE iom_init( cdname, kdid, ld_closedef ) 104 108 !!---------------------------------------------------------------------- 105 109 !! *** ROUTINE *** … … 109 113 !!---------------------------------------------------------------------- 110 114 CHARACTER(len=*), INTENT(in) :: cdname 111 CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname115 INTEGER , OPTIONAL, INTENT(in) :: kdid 112 116 LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef 113 117 #if defined key_iomput … … 118 122 INTEGER :: irefyear, irefmonth, irefday 119 123 INTEGER :: ji 120 LOGICAL :: llrst_context ! is context related to restart 124 LOGICAL :: llrst_context ! is context related to restart 125 LOGICAL :: llrstr, llrstw 126 INTEGER :: inum 121 127 ! 122 128 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 123 129 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 124 LOGICAL :: ll_closedef = .TRUE.130 LOGICAL :: ll_closedef 125 131 LOGICAL :: ll_exist 126 132 !!---------------------------------------------------------------------- 127 133 ! 134 ll_closedef = .TRUE. 128 135 IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 129 136 ! … … 134 141 CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) 135 142 CALL iom_swap( cdname ) 136 llrst_context = (TRIM(cdname) == TRIM(crxios_context) .OR. TRIM(cdname) == TRIM(cwxios_context)) 143 144 llrstr = (cdname == cr_ocerst_cxt) .OR. (cdname == cr_icerst_cxt) 145 llrstr = llrstr .OR. (cdname == cr_toprst_cxt) 146 llrstr = llrstr .OR. (cdname == cr_sedrst_cxt) 147 148 llrstw = (cdname == cw_ocerst_cxt) .OR. (cdname == cw_icerst_cxt) 149 llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 150 llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 151 152 llrst_context = llrstr .OR. llrstw 137 153 138 154 ! Calendar type is now defined in xml file … … 153 169 IF(.NOT.llrst_context) CALL set_scalar 154 170 ! 155 IF( TRIM(cdname) == TRIM(cxios_context)) THEN171 IF( cdname == cxios_context ) THEN 156 172 CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. ) 157 173 CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) … … 197 213 ! vertical grid definition 198 214 IF(.NOT.llrst_context) THEN 199 200 201 202 215 CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) 216 CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) 217 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 218 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 203 219 204 220 ! ABL 205 206 207 208 209 210 211 221 IF( .NOT. ALLOCATED(ght_abl) ) THEN ! force definition for xml files (xios) 222 ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) ) ! default allocation needed by iom 223 ght_abl(:) = -1._wp ; ghw_abl(:) = -1._wp 224 e3t_abl(:) = -1._wp ; e3w_abl(:) = -1._wp 225 ENDIF 226 CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 227 CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 212 228 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 229 ! Add vertical grid bounds 230 zt_bnds(2,: ) = gdept_1d(:) 231 zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) 232 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 233 zw_bnds(1,: ) = gdepw_1d(:) 234 zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 235 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 236 CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) 237 CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) 238 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 239 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 240 241 ! ABL 242 za_bnds(1,:) = ghw_abl(1:jpkam1) 243 za_bnds(2,:) = ghw_abl(2:jpka ) 244 CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 245 za_bnds(1,:) = ght_abl(2:jpka ) 246 za_bnds(2,:) = ght_abl(2:jpka ) + e3w_abl(2:jpka) 247 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 248 249 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 234 250 # if defined key_si3 235 236 237 251 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 252 ! SIMIP diagnostics (4 main arctic straits) 253 CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 238 254 # endif 239 255 #if defined key_top 240 241 #endif 242 243 244 245 246 247 248 249 256 IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 257 #endif 258 CALL iom_set_axis_attr( "icbcla", class_num ) 259 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... 260 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 261 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 262 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 263 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 264 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 265 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 250 266 ENDIF 251 267 ! 252 268 ! automatic definitions of some of the xml attributs 253 IF( TRIM(cdname) == TRIM(crxios_context) ) THEN 254 !set names of the fields in restart file IF using XIOS to read data 255 CALL iom_set_rst_context(.TRUE.) 256 CALL iom_set_rst_vars(rst_rfields) 257 !set which fields are to be read from restart file 258 CALL iom_set_rstr_active() 259 ELSE IF( TRIM(cdname) == TRIM(cwxios_context) ) THEN 260 !set names of the fields in restart file IF using XIOS to write data 261 CALL iom_set_rst_context(.FALSE.) 262 CALL iom_set_rst_vars(rst_wfields) 263 !set which fields are to be written to a restart file 264 CALL iom_set_rstw_active(fname) 269 IF(llrstr) THEN 270 IF(PRESENT(kdid)) THEN 271 CALL iom_set_rst_context(.TRUE.) 272 !set which fields will be read from restart file 273 CALL iom_set_vars_active(kdid) 274 ELSE 275 CALL ctl_stop( 'iom_init:', 'restart read with XIOS: missing pointer to NETCDF file' ) 276 ENDIF 277 ELSE IF(llrstw) THEN 278 CALL iom_set_rstw_file(iom_file(kdid)%name) 265 279 ELSE 266 280 CALL set_xmlatt 267 281 ENDIF 268 282 ! … … 280 294 END SUBROUTINE iom_init 281 295 282 SUBROUTINE iom_init_closedef 296 SUBROUTINE iom_init_closedef(cdname) 283 297 !!---------------------------------------------------------------------- 284 298 !! *** SUBROUTINE iom_init_closedef *** … … 288 302 !! 289 303 !!---------------------------------------------------------------------- 290 304 CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname 291 305 #if defined key_iomput 292 CALL xios_close_context_definition() 293 CALL xios_update_calendar( 0 ) 306 LOGICAL :: llrstw 307 308 llrstw = .FALSE. 309 IF(PRESENT(cdname)) THEN 310 llrstw = (cdname == cw_ocerst_cxt) 311 llrstw = llrstw .OR. (cdname == cw_icerst_cxt) 312 llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 313 llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 314 ENDIF 315 316 IF( llrstw ) THEN 317 !set names of the fields in restart file IF using XIOS to write data 318 CALL iom_set_rst_context(.FALSE.) 319 CALL xios_close_context_definition() 320 ELSE 321 CALL xios_close_context_definition() 322 CALL xios_update_calendar( 0 ) 323 ENDIF 294 324 #else 295 325 IF( .FALSE. ) WRITE(numout,*) 'iom_init_closedef: should not see this' ! useless statement to avoid compilation warnings … … 298 328 END SUBROUTINE iom_init_closedef 299 329 300 SUBROUTINE iom_set_ rstw_var_active(field)330 SUBROUTINE iom_set_vars_active(idnum) 301 331 !!--------------------------------------------------------------------- 302 !! *** SUBROUTINE iom_set_rstw_var_active *** 303 !! 304 !! ** Purpose : enable variable in restart file when writing with XIOS 332 !! *** SUBROUTINE iom_set_vars_active *** 333 !! 334 !! ** Purpose : define filename in XIOS context for reading file, 335 !! enable variables present in a file for reading with XIOS 336 !! id of the file is assumed to be rrestart. 305 337 !!--------------------------------------------------------------------- 306 CHARACTER(len = *), INTENT(IN) :: field 307 INTEGER :: i 308 LOGICAL :: llis_set 309 CHARACTER(LEN=256) :: clinfo ! info character 310 338 INTEGER, INTENT(IN) :: idnum 339 311 340 #if defined key_iomput 312 llis_set = .FALSE. 313 314 DO i = 1, max_rst_fields 315 IF(TRIM(rst_wfields(i)%vname) == field) THEN 316 rst_wfields(i)%active = .TRUE. 317 llis_set = .TRUE. 318 EXIT 319 ENDIF 320 ENDDO 321 !Warn if variable is not in defined in rst_wfields 322 IF(.NOT.llis_set) THEN 323 WRITE(ctmp1,*) 'iom_set_rstw_var_active: variable ', field ,' is available for writing but not defined' 324 CALL ctl_stop( 'iom_set_rstw_var_active:', ctmp1 ) 325 ENDIF 326 #else 327 clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality' 328 CALL ctl_stop('STOP', TRIM(clinfo)) 329 #endif 330 331 END SUBROUTINE iom_set_rstw_var_active 332 333 SUBROUTINE iom_set_rstr_active() 341 INTEGER :: ndims, nvars, natts, unlimitedDimId, dimlen, xtype,mdims 342 TYPE(xios_field) :: field_hdl 343 TYPE(xios_file) :: file_hdl 344 TYPE(xios_filegroup) :: filegroup_hdl 345 INTEGER :: dimids(4), jv,i, idim 346 CHARACTER(LEN=256) :: clinfo ! info character 347 INTEGER, ALLOCATABLE :: indimlens(:) 348 CHARACTER(LEN=nf90_max_name), ALLOCATABLE :: indimnames(:) 349 CHARACTER(LEN=nf90_max_name) :: dimname, varname 350 INTEGER :: iln 351 CHARACTER(LEN=lc) :: fname 352 LOGICAL :: lmeta 353 !metadata in restart file for restart read with XIOS 354 INTEGER, PARAMETER :: NMETA = 10 355 CHARACTER(LEN=lc) :: meta(NMETA) 356 357 358 meta(1) = "nav_lat" 359 meta(2) = "nav_lon" 360 meta(3) = "nav_lev" 361 meta(4) = "time_instant" 362 meta(5) = "time_instant_bounds" 363 meta(6) = "time_counter" 364 meta(7) = "time_counter_bounds" 365 meta(8) = "x" 366 meta(9) = "y" 367 meta(10) = "numcat" 368 369 clinfo = ' iom_set_vars_active, file: '//TRIM(iom_file(idnum)%name) 370 371 iln = INDEX( iom_file(idnum)%name, '.nc' ) 372 !XIOS doee not need .nc 373 IF(iln > 0) THEN 374 fname = iom_file(idnum)%name(1:iln-1) 375 ELSE 376 fname = iom_file(idnum)%name 377 ENDIF 378 379 !set name of the restart file and enable available fields 380 CALL xios_get_handle("file_definition", filegroup_hdl ) 381 CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 382 CALL xios_set_file_attr( "rrestart", name=fname, type="one_file", & 383 par_access="collective", enabled=.TRUE., mode="read", & 384 output_freq=xios_timestep ) 385 386 CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, ndims, nvars, natts ), clinfo ) 387 ALLOCATE(indimlens(ndims), indimnames(ndims)) 388 CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, unlimitedDimId = unlimitedDimId ), clinfo ) 389 390 DO idim = 1, ndims 391 CALL iom_nf90_check( nf90_inquire_dimension(iom_file(idnum)%nfid, idim, dimname, dimlen ), clinfo ) 392 indimlens(idim) = dimlen 393 indimnames(idim) = dimname 394 ENDDO 395 396 DO jv =1, nvars 397 lmeta = .FALSE. 398 CALL iom_nf90_check( nf90_inquire_variable(iom_file(idnum)%nfid, jv, varname, xtype, ndims, dimids, natts ), clinfo ) 399 DO i = 1, NMETA 400 IF(varname == meta(i)) THEN 401 lmeta = .TRUE. 402 ENDIF 403 ENDDO 404 IF(.NOT.lmeta) THEN 405 CALL xios_add_child(file_hdl, field_hdl, varname) 406 mdims = ndims 407 408 IF(ANY(dimids(1:ndims) == unlimitedDimId)) THEN 409 mdims = mdims - 1 410 ENDIF 411 412 IF(mdims == 3) THEN 413 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 414 domain_ref="grid_N", & 415 axis_ref=iom_axis(indimlens(dimids(mdims))), & 416 prec = 8, operation = "instant" ) 417 ELSEIF(mdims == 2) THEN 418 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 419 domain_ref="grid_N", prec = 8, & 420 operation = "instant" ) 421 ELSEIF(mdims == 1) THEN 422 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 423 axis_ref=iom_axis(indimlens(dimids(mdims))), & 424 prec = 8, operation = "instant" ) 425 ELSEIF(mdims == 0) THEN 426 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 427 scalar_ref = "grid_scalar", prec = 8, & 428 operation = "instant" ) 429 ELSE 430 WRITE(ctmp1,*) 'iom_set_vars_active: variable ', TRIM(varname) ,' incorrect number of dimensions' 431 CALL ctl_stop( 'iom_set_vars_active:', ctmp1 ) 432 ENDIF 433 ENDIF 434 ENDDO 435 DEALLOCATE(indimlens, indimnames) 436 #endif 437 END SUBROUTINE iom_set_vars_active 438 439 SUBROUTINE iom_set_rstw_file(cdrst_file) 334 440 !!--------------------------------------------------------------------- 335 !! *** SUBROUTINE iom_set_rstr_active *** 336 !! 337 !! ** Purpose : define file name in XIOS context for reading restart file, 338 !! enable variables present in restart file for reading with XIOS 441 !! *** SUBROUTINE iom_set_rstw_file *** 442 !! 443 !! ** Purpose : define file name in XIOS context for writing restart 339 444 !!--------------------------------------------------------------------- 340 341 !sets enabled = .TRUE. for each field in restart file 342 CHARACTER(len=256) :: rst_file 343 445 CHARACTER(len=*) :: cdrst_file 344 446 #if defined key_iomput 345 TYPE(xios_field) :: field_hdl 346 TYPE(xios_file) :: file_hdl 347 TYPE(xios_filegroup) :: filegroup_hdl 348 INTEGER :: i 349 CHARACTER(lc) :: clpath 350 351 clpath = TRIM(cn_ocerst_indir) 352 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 353 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 354 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 355 ELSE 356 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 357 ENDIF 447 TYPE(xios_file) :: file_hdl 448 TYPE(xios_filegroup) :: filegroup_hdl 449 358 450 !set name of the restart file and enable available fields 359 if(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS) to: ',rst_file 360 CALL xios_get_handle("file_definition", filegroup_hdl ) 361 CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 362 CALL xios_set_file_attr( "rrestart", name=trim(rst_file), type="one_file", & 363 par_access="collective", enabled=.TRUE., mode="read", & 364 output_freq=xios_timestep) 365 !define variables for restart context 366 DO i = 1, max_rst_fields 367 IF( TRIM(rst_rfields(i)%vname) /= "NO_NAME") THEN 368 IF( iom_varid( numror, TRIM(rst_rfields(i)%vname), ldstop = .FALSE. ) > 0 ) THEN 369 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_rfields(i)%vname)) 370 SELECT CASE (TRIM(rst_rfields(i)%grid)) 371 CASE ("grid_N_3D") 372 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 373 domain_ref="grid_N", axis_ref="nav_lev", operation = "instant") 374 CASE ("grid_N") 375 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 376 domain_ref="grid_N", operation = "instant") 377 CASE ("grid_vector") 378 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 379 axis_ref="nav_lev", operation = "instant") 380 CASE ("grid_scalar") 381 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 382 scalar_ref = "grid_scalar", operation = "instant") 383 END SELECT 384 IF(lwp) WRITE(numout,*) 'XIOS read: ', TRIM(rst_rfields(i)%vname), ' enabled in ', TRIM(rst_file) 385 ENDIF 386 ENDIF 387 END DO 388 #endif 389 END SUBROUTINE iom_set_rstr_active 390 391 SUBROUTINE iom_set_rstw_core(cdmdl) 392 !!--------------------------------------------------------------------- 393 !! *** SUBROUTINE iom_set_rstw_core *** 394 !! 395 !! ** Purpose : set variables which are always in restart file 396 !!--------------------------------------------------------------------- 397 CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS 398 CHARACTER(LEN=256) :: clinfo ! info character 399 #if defined key_iomput 400 IF(cdmdl == "OPA") THEN 401 !from restart.F90 402 CALL iom_set_rstw_var_active("rn_Dt") 403 IF ( .NOT. ln_diurnal_only ) THEN 404 CALL iom_set_rstw_var_active('ub' ) 405 CALL iom_set_rstw_var_active('vb' ) 406 CALL iom_set_rstw_var_active('tb' ) 407 CALL iom_set_rstw_var_active('sb' ) 408 CALL iom_set_rstw_var_active('sshb') 409 ! 410 CALL iom_set_rstw_var_active('un' ) 411 CALL iom_set_rstw_var_active('vn' ) 412 CALL iom_set_rstw_var_active('tn' ) 413 CALL iom_set_rstw_var_active('sn' ) 414 CALL iom_set_rstw_var_active('sshn') 415 CALL iom_set_rstw_var_active('rhop') 416 ENDIF 417 IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst') 418 !from trasbc.F90 419 CALL iom_set_rstw_var_active('sbc_hc_b') 420 CALL iom_set_rstw_var_active('sbc_sc_b') 421 ENDIF 422 #else 423 clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality' 424 CALL ctl_stop('STOP', TRIM(clinfo)) 425 #endif 426 END SUBROUTINE iom_set_rstw_core 427 428 SUBROUTINE iom_set_rst_vars(fields) 429 !!--------------------------------------------------------------------- 430 !! *** SUBROUTINE iom_set_rst_vars *** 431 !! 432 !! ** Purpose : Fill array fields with the information about all 433 !! possible variables and corresponding grids definition 434 !! for reading/writing restart with XIOS 435 !!--------------------------------------------------------------------- 436 TYPE(RST_FIELD), INTENT(INOUT) :: fields(max_rst_fields) 437 INTEGER :: i 438 439 i = 0 440 i = i + 1; fields(i)%vname="rn_Dt"; fields(i)%grid="grid_scalar" 441 i = i + 1; fields(i)%vname="un"; fields(i)%grid="grid_N_3D" 442 i = i + 1; fields(i)%vname="ub"; fields(i)%grid="grid_N_3D" 443 i = i + 1; fields(i)%vname="vn"; fields(i)%grid="grid_N_3D" 444 i = i + 1; fields(i)%vname="vb"; fields(i)%grid="grid_N_3D" 445 i = i + 1; fields(i)%vname="tn"; fields(i)%grid="grid_N_3D" 446 i = i + 1; fields(i)%vname="tb"; fields(i)%grid="grid_N_3D" 447 i = i + 1; fields(i)%vname="sn"; fields(i)%grid="grid_N_3D" 448 i = i + 1; fields(i)%vname="sb"; fields(i)%grid="grid_N_3D" 449 i = i + 1; fields(i)%vname="sshn"; fields(i)%grid="grid_N" 450 i = i + 1; fields(i)%vname="sshb"; fields(i)%grid="grid_N" 451 i = i + 1; fields(i)%vname="rhop"; fields(i)%grid="grid_N_3D" 452 i = i + 1; fields(i)%vname="kt"; fields(i)%grid="grid_scalar" 453 i = i + 1; fields(i)%vname="ndastp"; fields(i)%grid="grid_scalar" 454 i = i + 1; fields(i)%vname="adatrj"; fields(i)%grid="grid_scalar" 455 i = i + 1; fields(i)%vname="utau_b"; fields(i)%grid="grid_N" 456 i = i + 1; fields(i)%vname="vtau_b"; fields(i)%grid="grid_N" 457 i = i + 1; fields(i)%vname="qns_b"; fields(i)%grid="grid_N" 458 i = i + 1; fields(i)%vname="emp_b"; fields(i)%grid="grid_N" 459 i = i + 1; fields(i)%vname="sfx_b"; fields(i)%grid="grid_N" 460 i = i + 1; fields(i)%vname="en" ; fields(i)%grid="grid_N_3D" 461 i = i + 1; fields(i)%vname="avt_k"; fields(i)%grid="grid_N_3D" 462 i = i + 1; fields(i)%vname="avm_k"; fields(i)%grid="grid_N_3D" 463 i = i + 1; fields(i)%vname="dissl"; fields(i)%grid="grid_N_3D" 464 i = i + 1; fields(i)%vname="sbc_hc_b"; fields(i)%grid="grid_N" 465 i = i + 1; fields(i)%vname="sbc_sc_b"; fields(i)%grid="grid_N" 466 i = i + 1; fields(i)%vname="qsr_hc_b"; fields(i)%grid="grid_N_3D" 467 i = i + 1; fields(i)%vname="fraqsr_1lev"; fields(i)%grid="grid_N" 468 i = i + 1; fields(i)%vname="greenland_icesheet_mass" 469 fields(i)%grid="grid_scalar" 470 i = i + 1; fields(i)%vname="greenland_icesheet_timelapsed" 471 fields(i)%grid="grid_scalar" 472 i = i + 1; fields(i)%vname="greenland_icesheet_mass_roc" 473 fields(i)%grid="grid_scalar" 474 i = i + 1; fields(i)%vname="antarctica_icesheet_mass" 475 fields(i)%grid="grid_scalar" 476 i = i + 1; fields(i)%vname="antarctica_icesheet_timelapsed" 477 fields(i)%grid="grid_scalar" 478 i = i + 1; fields(i)%vname="antarctica_icesheet_mass_roc" 479 fields(i)%grid="grid_scalar" 480 i = i + 1; fields(i)%vname="frc_v"; fields(i)%grid="grid_scalar" 481 i = i + 1; fields(i)%vname="frc_t"; fields(i)%grid="grid_scalar" 482 i = i + 1; fields(i)%vname="frc_s"; fields(i)%grid="grid_scalar" 483 i = i + 1; fields(i)%vname="frc_wn_t"; fields(i)%grid="grid_scalar" 484 i = i + 1; fields(i)%vname="frc_wn_s"; fields(i)%grid="grid_scalar" 485 i = i + 1; fields(i)%vname="ssh_ini"; fields(i)%grid="grid_N" 486 i = i + 1; fields(i)%vname="e3t_ini"; fields(i)%grid="grid_N_3D" 487 i = i + 1; fields(i)%vname="hc_loc_ini"; fields(i)%grid="grid_N_3D" 488 i = i + 1; fields(i)%vname="sc_loc_ini"; fields(i)%grid="grid_N_3D" 489 i = i + 1; fields(i)%vname="ssh_hc_loc_ini"; fields(i)%grid="grid_N" 490 i = i + 1; fields(i)%vname="ssh_sc_loc_ini"; fields(i)%grid="grid_N" 491 i = i + 1; fields(i)%vname="tilde_e3t_b"; fields(i)%grid="grid_N" 492 i = i + 1; fields(i)%vname="tilde_e3t_n"; fields(i)%grid="grid_N" 493 i = i + 1; fields(i)%vname="hdiv_lf"; fields(i)%grid="grid_N" 494 i = i + 1; fields(i)%vname="ub2_b"; fields(i)%grid="grid_N" 495 i = i + 1; fields(i)%vname="vb2_b"; fields(i)%grid="grid_N" 496 i = i + 1; fields(i)%vname="sshbb_e"; fields(i)%grid="grid_N" 497 i = i + 1; fields(i)%vname="ubb_e"; fields(i)%grid="grid_N" 498 i = i + 1; fields(i)%vname="vbb_e"; fields(i)%grid="grid_N" 499 i = i + 1; fields(i)%vname="sshb_e"; fields(i)%grid="grid_N" 500 i = i + 1; fields(i)%vname="ub_e"; fields(i)%grid="grid_N" 501 i = i + 1; fields(i)%vname="vb_e"; fields(i)%grid="grid_N" 502 i = i + 1; fields(i)%vname="fwf_isf_b"; fields(i)%grid="grid_N" 503 i = i + 1; fields(i)%vname="isf_sc_b"; fields(i)%grid="grid_N" 504 i = i + 1; fields(i)%vname="isf_hc_b"; fields(i)%grid="grid_N" 505 i = i + 1; fields(i)%vname="ssh_ibb"; fields(i)%grid="grid_N" 506 i = i + 1; fields(i)%vname="rnf_b"; fields(i)%grid="grid_N" 507 i = i + 1; fields(i)%vname="rnf_hc_b"; fields(i)%grid="grid_N" 508 i = i + 1; fields(i)%vname="rnf_sc_b"; fields(i)%grid="grid_N" 509 i = i + 1; fields(i)%vname="nn_fsbc"; fields(i)%grid="grid_scalar" 510 i = i + 1; fields(i)%vname="ssu_m"; fields(i)%grid="grid_N" 511 i = i + 1; fields(i)%vname="ssv_m"; fields(i)%grid="grid_N" 512 i = i + 1; fields(i)%vname="sst_m"; fields(i)%grid="grid_N" 513 i = i + 1; fields(i)%vname="sss_m"; fields(i)%grid="grid_N" 514 i = i + 1; fields(i)%vname="ssh_m"; fields(i)%grid="grid_N" 515 i = i + 1; fields(i)%vname="e3t_m"; fields(i)%grid="grid_N" 516 i = i + 1; fields(i)%vname="frq_m"; fields(i)%grid="grid_N" 517 i = i + 1; fields(i)%vname="avmb"; fields(i)%grid="grid_vector" 518 i = i + 1; fields(i)%vname="avtb"; fields(i)%grid="grid_vector" 519 i = i + 1; fields(i)%vname="ub2_i_b"; fields(i)%grid="grid_N" 520 i = i + 1; fields(i)%vname="vb2_i_b"; fields(i)%grid="grid_N" 521 i = i + 1; fields(i)%vname="ntime"; fields(i)%grid="grid_scalar" 522 i = i + 1; fields(i)%vname="Dsst"; fields(i)%grid="grid_scalar" 523 i = i + 1; fields(i)%vname="tmask"; fields(i)%grid="grid_N_3D" 524 i = i + 1; fields(i)%vname="umask"; fields(i)%grid="grid_N_3D" 525 i = i + 1; fields(i)%vname="vmask"; fields(i)%grid="grid_N_3D" 526 i = i + 1; fields(i)%vname="smask"; fields(i)%grid="grid_N_3D" 527 i = i + 1; fields(i)%vname="gdepw_n"; fields(i)%grid="grid_N_3D" 528 i = i + 1; fields(i)%vname="e3t_n"; fields(i)%grid="grid_N_3D" 529 i = i + 1; fields(i)%vname="e3u_n"; fields(i)%grid="grid_N_3D" 530 i = i + 1; fields(i)%vname="e3v_n"; fields(i)%grid="grid_N_3D" 531 i = i + 1; fields(i)%vname="surf_ini"; fields(i)%grid="grid_N" 532 i = i + 1; fields(i)%vname="e3t_b"; fields(i)%grid="grid_N_3D" 533 i = i + 1; fields(i)%vname="hmxl_n"; fields(i)%grid="grid_N_3D" 534 i = i + 1; fields(i)%vname="un_bf"; fields(i)%grid="grid_N" 535 i = i + 1; fields(i)%vname="vn_bf"; fields(i)%grid="grid_N" 536 i = i + 1; fields(i)%vname="hbl"; fields(i)%grid="grid_N" 537 i = i + 1; fields(i)%vname="hbli"; fields(i)%grid="grid_N" 538 i = i + 1; fields(i)%vname="wn"; fields(i)%grid="grid_N_3D" 539 540 IF( i-1 > max_rst_fields) THEN 541 WRITE(ctmp1,*) 'E R R O R : iom_set_rst_vars SIZE of RST_FIELD array is too small' 542 CALL ctl_stop( 'iom_set_rst_vars:', ctmp1 ) 543 ENDIF 544 END SUBROUTINE iom_set_rst_vars 545 546 547 SUBROUTINE iom_set_rstw_active(cdrst_file) 451 IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ', TRIM(cdrst_file) 452 CALL xios_get_handle("file_definition", filegroup_hdl ) 453 CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 454 IF(nxioso.eq.1) THEN 455 CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& 456 mode="write", output_freq=xios_timestep) 457 IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' 458 ELSE 459 CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& 460 mode="write", output_freq=xios_timestep) 461 IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' 462 ENDIF 463 CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 464 #endif 465 END SUBROUTINE iom_set_rstw_file 466 467 468 SUBROUTINE iom_set_rstw_active(sdfield, rd0, rs0, rd1, rs1, rd2, rs2, rd3, rs3) 548 469 !!--------------------------------------------------------------------- 549 470 !! *** SUBROUTINE iom_set_rstw_active *** … … 553 474 !!--------------------------------------------------------------------- 554 475 !sets enabled = .TRUE. for each field in restart file 555 CHARACTER(len=*) :: cdrst_file 476 CHARACTER(len = *), INTENT(IN) :: sdfield 477 REAL(dp), OPTIONAL, INTENT(IN) :: rd0 478 REAL(sp), OPTIONAL, INTENT(IN) :: rs0 479 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rd1 480 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rs1 481 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rd2 482 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rs2 483 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3 484 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3 556 485 #if defined key_iomput 557 TYPE(xios_field) :: field_hdl 558 TYPE(xios_file) :: file_hdl 559 TYPE(xios_filegroup) :: filegroup_hdl 560 INTEGER :: i 561 CHARACTER(lc) :: clpath 562 563 !set name of the restart file and enable available fields 564 IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ',cdrst_file 565 CALL xios_get_handle("file_definition", filegroup_hdl ) 566 CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 567 IF(nxioso.eq.1) THEN 568 CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& 569 mode="write", output_freq=xios_timestep) 570 if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' 571 ELSE 572 CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& 573 mode="write", output_freq=xios_timestep) 574 if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' 575 ENDIF 576 CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 486 TYPE(xios_field) :: field_hdl 487 TYPE(xios_file) :: file_hdl 488 489 CALL xios_get_handle("wrestart", file_hdl) 577 490 !define fields for restart context 578 DO i = 1, max_rst_fields 579 IF( rst_wfields(i)%active ) THEN 580 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_wfields(i)%vname)) 581 SELECT CASE (TRIM(rst_wfields(i)%grid)) 582 CASE ("grid_N_3D") 583 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 584 domain_ref="grid_N", axis_ref="nav_lev", prec = 8, operation = "instant") 585 CASE ("grid_N") 586 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 587 domain_ref="grid_N", prec = 8, operation = "instant") 588 CASE ("grid_vector") 589 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 590 axis_ref="nav_lev", prec = 8, operation = "instant") 591 CASE ("grid_scalar") 592 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 593 scalar_ref = "grid_scalar", prec = 8, operation = "instant") 594 END SELECT 595 ENDIF 596 END DO 491 CALL xios_add_child(file_hdl, field_hdl, sdfield) 492 493 IF(PRESENT(rd3)) THEN 494 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 495 domain_ref = "grid_N", & 496 axis_ref = iom_axis(size(rd3, 3)), & 497 prec = 8, operation = "instant" ) 498 ELSEIF(PRESENT(rs3)) THEN 499 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 500 domain_ref = "grid_N", & 501 axis_ref = iom_axis(size(rd3, 3)), & 502 prec = 4, operation = "instant" ) 503 ELSEIF(PRESENT(rd2)) THEN 504 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 505 domain_ref = "grid_N", prec = 8, & 506 operation = "instant" ) 507 ELSEIF(PRESENT(rs2)) THEN 508 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 509 domain_ref = "grid_N", prec = 4, & 510 operation = "instant" ) 511 ELSEIF(PRESENT(rd1)) THEN 512 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 513 axis_ref = iom_axis(size(rd1, 1)), & 514 prec = 8, operation = "instant" ) 515 ELSEIF(PRESENT(rs1)) THEN 516 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 517 axis_ref = iom_axis(size(rd1, 1)), & 518 prec = 4, operation = "instant" ) 519 ELSEIF(PRESENT(rd0)) THEN 520 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 521 scalar_ref = "grid_scalar", prec = 8, & 522 operation = "instant" ) 523 ELSEIF(PRESENT(rs0)) THEN 524 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 525 scalar_ref = "grid_scalar", prec = 4, & 526 operation = "instant" ) 527 ENDIF 597 528 #endif 598 529 END SUBROUTINE iom_set_rstw_active 599 530 531 FUNCTION iom_axis(idlev) result(axis_ref) 532 !!--------------------------------------------------------------------- 533 !! *** FUNCTION iom_axis *** 534 !! 535 !! ** Purpose : Used for grid definition when XIOS is used to read/write 536 !! restart. Returns axis corresponding to the number of levels 537 !! given as an input variable. Axes are defined in routine 538 !! iom_set_rst_context 539 !!--------------------------------------------------------------------- 540 INTEGER, INTENT(IN) :: idlev 541 CHARACTER(len=lc) :: axis_ref 542 CHARACTER(len=12) :: str 543 IF(idlev == jpk) THEN 544 axis_ref="nav_lev" 545 #if defined key_si3 546 ELSEIF(idlev == jpl) THEN 547 axis_ref="numcat" 548 #endif 549 ELSE 550 write(str, *) idlev 551 CALL ctl_stop( 'iom_axis', 'Definition for axis with '//TRIM(ADJUSTL(str))//' levels missing') 552 ENDIF 553 END FUNCTION iom_axis 554 555 FUNCTION iom_xios_setid(cdname) result(kid) 556 !!--------------------------------------------------------------------- 557 !! *** FUNCTION *** 558 !! 559 !! ** Purpose : this function returns first available id to keep information about file 560 !! sets filename in iom_file structure and sets name 561 !! of XIOS context depending on cdcomp 562 !! corresponds to iom_nf90_open 563 !!--------------------------------------------------------------------- 564 CHARACTER(len=*), INTENT(in ) :: cdname ! File name 565 INTEGER :: kid ! identifier of the opened file 566 INTEGER :: jl 567 568 kid = 0 569 DO jl = jpmax_files, 1, -1 570 IF( iom_file(jl)%nfid == 0 ) kid = jl 571 ENDDO 572 573 iom_file(kid)%name = TRIM(cdname) 574 iom_file(kid)%nfid = 1 575 iom_file(kid)%nvars = 0 576 iom_file(kid)%irec = -1 577 578 END FUNCTION iom_xios_setid 579 600 580 SUBROUTINE iom_set_rst_context(ld_rstr) 601 !!---------------------------------------------------------------------581 !!--------------------------------------------------------------------- 602 582 !! *** SUBROUTINE iom_set_rst_context *** 603 583 !! … … 606 586 !! 607 587 !!--------------------------------------------------------------------- 608 LOGICAL, INTENT(IN) :: ld_rstr 609 !ld_rstr is true for restart context. There is no need to define grid for 610 !restart read, because it's read from file 588 LOGICAL, INTENT(IN) :: ld_rstr 589 INTEGER :: ji 611 590 #if defined key_iomput 612 TYPE(xios_domaingroup) :: domaingroup_hdl613 TYPE(xios_domain) :: domain_hdl614 TYPE(xios_axisgroup) :: axisgroup_hdl615 TYPE(xios_axis) :: axis_hdl616 TYPE(xios_scalar) :: scalar_hdl617 TYPE(xios_scalargroup) :: scalargroup_hdl618 619 CALL xios_get_handle("domain_definition",domaingroup_hdl)620 CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N")621 CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr)591 TYPE(xios_domaingroup) :: domaingroup_hdl 592 TYPE(xios_domain) :: domain_hdl 593 TYPE(xios_axisgroup) :: axisgroup_hdl 594 TYPE(xios_axis) :: axis_hdl 595 TYPE(xios_scalar) :: scalar_hdl 596 TYPE(xios_scalargroup) :: scalargroup_hdl 597 598 CALL xios_get_handle("domain_definition",domaingroup_hdl) 599 CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N") 600 CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr) 622 601 623 CALL xios_get_handle("axis_definition",axisgroup_hdl)624 CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev")602 CALL xios_get_handle("axis_definition",axisgroup_hdl) 603 CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev") 625 604 !AGRIF fails to compile when unit= is in call to xios_set_axis_attr 626 ! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") 627 CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels in meters", positive="down") 628 CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) 629 630 CALL xios_get_handle("scalar_definition", scalargroup_hdl) 631 CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") 605 ! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") 606 CALL xios_set_axis_attr( "nav_lev", long_name = "Vertical levels in meters", positive = "down") 607 CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) 608 #if defined key_si3 609 CALL xios_add_child(axisgroup_hdl, axis_hdl, "numcat") 610 CALL iom_set_axis_attr( "numcat", (/ (REAL(ji,wp), ji=1,jpl) /) ) 611 #endif 612 CALL xios_get_handle("scalar_definition", scalargroup_hdl) 613 CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") 632 614 #endif 633 615 END SUBROUTINE iom_set_rst_context 616 617 618 SUBROUTINE set_xios_context(kdid, cdcont) 619 !!--------------------------------------------------------------------- 620 !! *** SUBROUTINE iom_set_rst_context *** 621 !! 622 !! ** Purpose : set correct XIOS context based on kdid 623 !! 624 !!--------------------------------------------------------------------- 625 INTEGER, INTENT(IN) :: kdid ! Identifier of the file 626 CHARACTER(LEN=lc), INTENT(OUT) :: cdcont ! name of the context for XIOS read/write 627 628 cdcont = "NONE" 629 630 IF(lrxios) THEN 631 IF(kdid == numror) THEN 632 cdcont = cr_ocerst_cxt 633 ELSEIF(kdid == numrir) THEN 634 cdcont = cr_icerst_cxt 635 ELSEIF(kdid == numrtr) THEN 636 cdcont = cr_toprst_cxt 637 ELSEIF(kdid == numrsr) THEN 638 cdcont = cr_sedrst_cxt 639 ENDIF 640 ENDIF 641 642 IF(lwxios) THEN 643 IF(kdid == numrow) THEN 644 cdcont = cw_ocerst_cxt 645 ELSEIF(kdid == numriw) THEN 646 cdcont = cw_icerst_cxt 647 ELSEIF(kdid == numrtw) THEN 648 cdcont = cw_toprst_cxt 649 ELSEIF(kdid == numrsw) THEN 650 cdcont = cw_sedrst_cxt 651 ENDIF 652 ENDIF 653 END SUBROUTINE set_xios_context 654 634 655 635 656 SUBROUTINE iom_swap( cdname ) … … 642 663 #if defined key_iomput 643 664 TYPE(xios_context) :: nemo_hdl 644 645 665 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 646 666 CALL xios_get_handle(TRIM(cdname),nemo_hdl) … … 892 912 !! INTERFACE iom_get 893 913 !!---------------------------------------------------------------------- 894 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime , ldxios)914 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) 895 915 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 896 916 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable … … 898 918 REAL(dp) :: ztmp_pvar ! tmp var to read field 899 919 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 900 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart901 920 ! 902 921 INTEGER :: idvar ! variable id … … 906 925 CHARACTER(LEN=100) :: clname ! file name 907 926 CHARACTER(LEN=1) :: cldmspc ! 908 LOGICAL :: llxios 909 ! 910 llxios = .FALSE. 911 IF( PRESENT(ldxios) ) llxios = ldxios 912 913 IF(.NOT.llxios) THEN ! read data using default library 927 CHARACTER(LEN=lc) :: context 928 ! 929 CALL set_xios_context(kiomid, context) 930 931 IF(context == "NONE") THEN ! read data using default library 914 932 itime = 1 915 933 IF( PRESENT(ktime) ) itime = ktime … … 934 952 #if defined key_iomput 935 953 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 936 CALL iom_swap( TRIM(crxios_context))954 CALL iom_swap(context) 937 955 CALL xios_recv_field( trim(cdvar), pvar) 938 CALL iom_swap( TRIM(cxios_context))956 CALL iom_swap(cxios_context) 939 957 #else 940 958 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) … … 944 962 END SUBROUTINE iom_g0d_sp 945 963 946 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime , ldxios)964 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) 947 965 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 948 966 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 949 967 REAL(dp) , INTENT( out) :: pvar ! read field 950 968 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 951 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart952 969 ! 953 970 INTEGER :: idvar ! variable id … … 957 974 CHARACTER(LEN=100) :: clname ! file name 958 975 CHARACTER(LEN=1) :: cldmspc ! 959 LOGICAL :: llxios 960 ! 961 llxios = .FALSE. 962 IF( PRESENT(ldxios) ) llxios = ldxios 963 964 IF(.NOT.llxios) THEN ! read data using default library 976 CHARACTER(LEN=lc) :: context 977 ! 978 CALL set_xios_context(kiomid, context) 979 980 IF(context == "NONE") THEN ! read data using default library 965 981 itime = 1 966 982 IF( PRESENT(ktime) ) itime = ktime … … 984 1000 #if defined key_iomput 985 1001 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 986 CALL iom_swap( TRIM(crxios_context))1002 CALL iom_swap(context) 987 1003 CALL xios_recv_field( trim(cdvar), pvar) 988 CALL iom_swap( TRIM(cxios_context))1004 CALL iom_swap(cxios_context) 989 1005 #else 990 1006 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) … … 994 1010 END SUBROUTINE iom_g0d_dp 995 1011 996 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount , ldxios)1012 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 997 1013 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 998 1014 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1003 1019 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1004 1020 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1005 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1006 1021 ! 1007 1022 IF( kiomid > 0 ) THEN … … 1009 1024 ALLOCATE(ztmp_pvar(size(pvar,1))) 1010 1025 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1011 & ktime=ktime, kstart=kstart, kcount=kcount, & 1012 & ldxios=ldxios ) 1026 & ktime=ktime, kstart=kstart, kcount=kcount ) 1013 1027 pvar = ztmp_pvar 1014 1028 DEALLOCATE(ztmp_pvar) … … 1018 1032 1019 1033 1020 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount , ldxios)1034 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 1021 1035 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1022 1036 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1026 1040 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1027 1041 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1028 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1029 1042 ! 1030 1043 IF( kiomid > 0 ) THEN 1031 1044 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1032 & ktime=ktime, kstart=kstart, kcount=kcount, & 1033 & ldxios=ldxios ) 1045 & ktime=ktime, kstart=kstart, kcount=kcount) 1034 1046 ENDIF 1035 1047 END SUBROUTINE iom_g1d_dp 1036 1048 1037 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1049 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 1038 1050 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1039 1051 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1047 1059 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1048 1060 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1049 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1050 1061 ! 1051 1062 IF( kiomid > 0 ) THEN … … 1054 1065 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1055 1066 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1056 & kstart = kstart , kcount = kcount , ldxios=ldxios)1067 & kstart = kstart , kcount = kcount ) 1057 1068 pvar = ztmp_pvar 1058 1069 DEALLOCATE(ztmp_pvar) … … 1061 1072 END SUBROUTINE iom_g2d_sp 1062 1073 1063 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1074 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 1064 1075 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1065 1076 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1072 1083 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1073 1084 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1074 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1075 1085 ! 1076 1086 IF( kiomid > 0 ) THEN 1077 1087 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 1078 1088 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1079 & kstart = kstart , kcount = kcount , ldxios=ldxios)1089 & kstart = kstart , kcount = kcount ) 1080 1090 ENDIF 1081 1091 END SUBROUTINE iom_g2d_dp 1082 1092 1083 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1093 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 1084 1094 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1085 1095 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1093 1103 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1094 1104 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1095 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1096 1105 ! 1097 1106 IF( kiomid > 0 ) THEN … … 1100 1109 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 1101 1110 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1102 & kstart = kstart , kcount = kcount , ldxios=ldxios)1111 & kstart = kstart , kcount = kcount ) 1103 1112 pvar = ztmp_pvar 1104 1113 DEALLOCATE(ztmp_pvar) … … 1107 1116 END SUBROUTINE iom_g3d_sp 1108 1117 1109 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1118 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 1110 1119 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1111 1120 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1118 1127 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1119 1128 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1120 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1121 1129 ! 1122 1130 IF( kiomid > 0 ) THEN … … 1124 1132 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1125 1133 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1126 & kstart = kstart , kcount = kcount , ldxios=ldxios)1134 & kstart = kstart , kcount = kcount ) 1127 1135 END IF 1128 1136 ENDIF … … 1132 1140 1133 1141 SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & 1134 & cd_type, psgn, kfill, kstart, kcount , ldxios)1142 & cd_type, psgn, kfill, kstart, kcount ) 1135 1143 !!----------------------------------------------------------------------- 1136 1144 !! *** ROUTINE iom_get_123d *** … … 1152 1160 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1153 1161 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1154 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart1155 1162 ! 1156 1163 LOGICAL :: llok ! true if ok! 1157 LOGICAL :: llxios ! local definition for XIOS read1158 1164 INTEGER :: jl ! loop on number of dimension 1159 1165 INTEGER :: idom ! type of domain … … 1182 1188 REAL(dp) :: gma, gmi 1183 1189 !--------------------------------------------------------------------- 1184 ! 1190 CHARACTER(LEN=lc) :: context 1191 ! 1192 CALL set_xios_context(kiomid, context) 1185 1193 inlev = -1 1186 1194 IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) 1187 1195 ! 1188 llxios = .FALSE.1189 IF( PRESENT(ldxios) ) llxios = ldxios1190 !1191 1196 idom = kdom 1192 1197 istop = nstop 1193 1198 ! 1194 IF( .NOT.llxios) THEN1199 IF(context == "NONE") THEN 1195 1200 clname = iom_file(kiomid)%name ! esier to read 1196 1201 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) … … 1359 1364 #if defined key_iomput 1360 1365 !would be good to be able to check which context is active and swap only if current is not restart 1361 CALL iom_swap( TRIM(crxios_context) ) 1366 idvar = iom_varid( kiomid, cdvar ) 1367 CALL iom_swap(context) 1368 zsgn = 1._wp 1369 IF( PRESENT(psgn ) ) zsgn = psgn 1370 cl_type = 'T' 1371 IF( PRESENT(cd_type) ) cl_type = cd_type 1372 1362 1373 IF( PRESENT(pv_r3d) ) THEN 1363 1374 IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 1364 CALL xios_recv_field( trim(cdvar), pv_r3d) 1365 IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1375 CALL xios_recv_field( trim(cdvar), pv_r3d(:, :, :)) 1376 IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1377 CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) 1378 ENDIF 1366 1379 ELSEIF( PRESENT(pv_r2d) ) THEN 1367 1380 IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 1368 CALL xios_recv_field( trim(cdvar), pv_r2d) 1369 IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1381 CALL xios_recv_field( trim(cdvar), pv_r2d(:, :)) 1382 IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1383 CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) 1384 ENDIF 1370 1385 ELSEIF( PRESENT(pv_r1d) ) THEN 1371 1386 IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 1372 1387 CALL xios_recv_field( trim(cdvar), pv_r1d) 1373 1388 ENDIF 1374 CALL iom_swap( TRIM(cxios_context))1389 CALL iom_swap(cxios_context) 1375 1390 #else 1376 1391 istop = istop + 1 … … 1387 1402 zofs = iom_file(kiomid)%ofs(idvar) ! offset 1388 1403 IF( PRESENT(pv_r1d) ) THEN 1389 IF( zscf /= 1. ) pv_r1d(:) = pv_r1d(:) * zscf1390 IF( zofs /= 0. ) pv_r1d(:) = pv_r1d(:) + zofs1404 IF( zscf /= 1._wp ) pv_r1d(:) = pv_r1d(:) * zscf 1405 IF( zofs /= 0._wp ) pv_r1d(:) = pv_r1d(:) + zofs 1391 1406 ELSEIF( PRESENT(pv_r2d) ) THEN 1392 IF( zscf /= 1. ) pv_r2d(:,:) = pv_r2d(:,:) * zscf1393 IF( zofs /= 0. ) pv_r2d(:,:) = pv_r2d(:,:) + zofs1407 IF( zscf /= 1._wp) pv_r2d(:,:) = pv_r2d(:,:) * zscf 1408 IF( zofs /= 0._wp) pv_r2d(:,:) = pv_r2d(:,:) + zofs 1394 1409 ELSEIF( PRESENT(pv_r3d) ) THEN 1395 IF( zscf /= 1. ) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf1396 IF( zofs /= 0. ) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs1410 IF( zscf /= 1._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 1411 IF( zofs /= 0._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 1397 1412 ENDIF 1398 1413 ! … … 1568 1583 !! INTERFACE iom_rstput 1569 1584 !!---------------------------------------------------------------------- 1570 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1585 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1571 1586 INTEGER , INTENT(in) :: kt ! ocean time-step 1572 1587 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1575 1590 REAL(sp) , INTENT(in) :: pvar ! written field 1576 1591 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1577 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1578 LOGICAL :: llx ! local xios write flag 1579 INTEGER :: ivid ! variable id 1580 1581 llx = .FALSE. 1582 IF(PRESENT(ldxios)) llx = ldxios 1592 ! 1593 LOGICAL :: llx ! local xios write flag 1594 INTEGER :: ivid ! variable id 1595 CHARACTER(LEN=lc) :: context 1596 ! 1597 CALL set_xios_context(kiomid, context) 1598 1599 llx = .NOT. (context == "NONE") 1600 1583 1601 IF( llx ) THEN 1584 1602 #ifdef key_iomput 1585 IF( kt == kwrite ) THEN 1586 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1587 CALL xios_send_field(trim(cdvar), pvar) 1588 ENDIF 1603 IF( kt == kwrite ) THEN 1604 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1605 CALL iom_swap(context) 1606 CALL iom_put(trim(cdvar), pvar) 1607 CALL iom_swap(cxios_context) 1608 ELSE 1609 IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 1610 CALL iom_swap(context) 1611 CALL iom_set_rstw_active( trim(cdvar), rs0 = pvar ) 1612 CALL iom_swap(cxios_context) 1613 ENDIF 1589 1614 #endif 1590 1615 ELSE … … 1598 1623 END SUBROUTINE iom_rp0d_sp 1599 1624 1600 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1625 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1601 1626 INTEGER , INTENT(in) :: kt ! ocean time-step 1602 1627 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1605 1630 REAL(dp) , INTENT(in) :: pvar ! written field 1606 1631 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1607 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1608 LOGICAL :: llx ! local xios write flag 1609 INTEGER :: ivid ! variable id 1610 1611 llx = .FALSE. 1612 IF(PRESENT(ldxios)) llx = ldxios 1632 ! 1633 LOGICAL :: llx ! local xios write flag 1634 INTEGER :: ivid ! variable id 1635 CHARACTER(LEN=lc) :: context 1636 ! 1637 CALL set_xios_context(kiomid, context) 1638 1639 llx = .NOT. (context == "NONE") 1640 1613 1641 IF( llx ) THEN 1614 1642 #ifdef key_iomput 1615 IF( kt == kwrite ) THEN 1616 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1617 CALL xios_send_field(trim(cdvar), pvar) 1618 ENDIF 1643 IF( kt == kwrite ) THEN 1644 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1645 CALL iom_swap(context) 1646 CALL iom_put(trim(cdvar), pvar) 1647 CALL iom_swap(cxios_context) 1648 ELSE 1649 IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 1650 CALL iom_swap(context) 1651 CALL iom_set_rstw_active( trim(cdvar), rd0 = pvar ) 1652 CALL iom_swap(cxios_context) 1653 ENDIF 1619 1654 #endif 1620 1655 ELSE … … 1629 1664 1630 1665 1631 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1666 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1632 1667 INTEGER , INTENT(in) :: kt ! ocean time-step 1633 1668 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1636 1671 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1637 1672 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1638 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1639 LOGICAL :: llx ! local xios write flag 1640 INTEGER :: ivid ! variable id 1641 1642 llx = .FALSE. 1643 IF(PRESENT(ldxios)) llx = ldxios 1673 ! 1674 LOGICAL :: llx ! local xios write flag 1675 INTEGER :: ivid ! variable id 1676 CHARACTER(LEN=lc) :: context 1677 ! 1678 CALL set_xios_context(kiomid, context) 1679 1680 llx = .NOT. (context == "NONE") 1681 1644 1682 IF( llx ) THEN 1645 1683 #ifdef key_iomput 1646 IF( kt == kwrite ) THEN 1647 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1648 CALL xios_send_field(trim(cdvar), pvar) 1649 ENDIF 1684 IF( kt == kwrite ) THEN 1685 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1686 CALL iom_swap(context) 1687 CALL iom_put(trim(cdvar), pvar) 1688 CALL iom_swap(cxios_context) 1689 ELSE 1690 IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 1691 CALL iom_swap(context) 1692 CALL iom_set_rstw_active( trim(cdvar), rs1 = pvar ) 1693 CALL iom_swap(cxios_context) 1694 ENDIF 1650 1695 #endif 1651 1696 ELSE … … 1659 1704 END SUBROUTINE iom_rp1d_sp 1660 1705 1661 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1706 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1662 1707 INTEGER , INTENT(in) :: kt ! ocean time-step 1663 1708 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1666 1711 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1667 1712 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1668 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1669 LOGICAL :: llx ! local xios write flag 1670 INTEGER :: ivid ! variable id 1671 1672 llx = .FALSE. 1673 IF(PRESENT(ldxios)) llx = ldxios 1713 ! 1714 LOGICAL :: llx ! local xios write flag 1715 INTEGER :: ivid ! variable id 1716 CHARACTER(LEN=lc) :: context 1717 ! 1718 CALL set_xios_context(kiomid, context) 1719 1720 llx = .NOT. (context == "NONE") 1721 1674 1722 IF( llx ) THEN 1675 1723 #ifdef key_iomput 1676 IF( kt == kwrite ) THEN 1677 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1678 CALL xios_send_field(trim(cdvar), pvar) 1679 ENDIF 1724 IF( kt == kwrite ) THEN 1725 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1726 CALL iom_swap(context) 1727 CALL iom_put(trim(cdvar), pvar) 1728 CALL iom_swap(cxios_context) 1729 ELSE 1730 IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 1731 CALL iom_swap(context) 1732 CALL iom_set_rstw_active( trim(cdvar), rd1 = pvar ) 1733 CALL iom_swap(cxios_context) 1734 ENDIF 1680 1735 #endif 1681 1736 ELSE … … 1690 1745 1691 1746 1692 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1747 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1693 1748 INTEGER , INTENT(in) :: kt ! ocean time-step 1694 1749 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1697 1752 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1698 1753 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1699 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1700 LOGICAL :: llx 1701 INTEGER :: ivid ! variable id 1702 1703 llx = .FALSE. 1704 IF(PRESENT(ldxios)) llx = ldxios 1754 ! 1755 LOGICAL :: llx 1756 INTEGER :: ivid ! variable id 1757 CHARACTER(LEN=lc) :: context 1758 ! 1759 CALL set_xios_context(kiomid, context) 1760 1761 llx = .NOT. (context == "NONE") 1762 1705 1763 IF( llx ) THEN 1706 1764 #ifdef key_iomput 1707 IF( kt == kwrite ) THEN 1708 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1709 CALL xios_send_field(trim(cdvar), pvar) 1710 ENDIF 1765 IF( kt == kwrite ) THEN 1766 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1767 CALL iom_swap(context) 1768 CALL iom_put(trim(cdvar), pvar) 1769 CALL iom_swap(cxios_context) 1770 ELSE 1771 IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 1772 CALL iom_swap(context) 1773 CALL iom_set_rstw_active( trim(cdvar), rs2 = pvar ) 1774 CALL iom_swap(cxios_context) 1775 ENDIF 1711 1776 #endif 1712 1777 ELSE … … 1720 1785 END SUBROUTINE iom_rp2d_sp 1721 1786 1722 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1787 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1723 1788 INTEGER , INTENT(in) :: kt ! ocean time-step 1724 1789 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1727 1792 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1728 1793 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1729 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1730 LOGICAL :: llx 1731 INTEGER :: ivid ! variable id 1732 1733 llx = .FALSE. 1734 IF(PRESENT(ldxios)) llx = ldxios 1794 ! 1795 LOGICAL :: llx 1796 INTEGER :: ivid ! variable id 1797 CHARACTER(LEN=lc) :: context 1798 ! 1799 CALL set_xios_context(kiomid, context) 1800 1801 llx = .NOT. (context == "NONE") 1802 1735 1803 IF( llx ) THEN 1736 1804 #ifdef key_iomput 1737 IF( kt == kwrite ) THEN 1738 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1739 CALL xios_send_field(trim(cdvar), pvar) 1740 ENDIF 1805 IF( kt == kwrite ) THEN 1806 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1807 CALL iom_swap(context) 1808 CALL iom_put(trim(cdvar), pvar) 1809 CALL iom_swap(cxios_context) 1810 ELSE 1811 IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 1812 CALL iom_swap(context) 1813 CALL iom_set_rstw_active( trim(cdvar), rd2 = pvar ) 1814 CALL iom_swap(cxios_context) 1815 ENDIF 1741 1816 #endif 1742 1817 ELSE … … 1751 1826 1752 1827 1753 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1828 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1754 1829 INTEGER , INTENT(in) :: kt ! ocean time-step 1755 1830 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1758 1833 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1759 1834 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1760 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1761 LOGICAL :: llx ! local xios write flag 1762 INTEGER :: ivid ! variable id 1763 1764 llx = .FALSE. 1765 IF(PRESENT(ldxios)) llx = ldxios 1835 ! 1836 LOGICAL :: llx ! local xios write flag 1837 INTEGER :: ivid ! variable id 1838 CHARACTER(LEN=lc) :: context 1839 ! 1840 CALL set_xios_context(kiomid, context) 1841 1842 llx = .NOT. (context == "NONE") 1843 1766 1844 IF( llx ) THEN 1767 1845 #ifdef key_iomput 1768 IF( kt == kwrite ) THEN 1769 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1770 CALL xios_send_field(trim(cdvar), pvar) 1771 ENDIF 1846 IF( kt == kwrite ) THEN 1847 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1848 CALL iom_swap(context) 1849 CALL iom_put(trim(cdvar), pvar) 1850 CALL iom_swap(cxios_context) 1851 ELSE 1852 IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 1853 CALL iom_swap(context) 1854 CALL iom_set_rstw_active( trim(cdvar), rs3 = pvar ) 1855 CALL iom_swap(cxios_context) 1856 ENDIF 1772 1857 #endif 1773 1858 ELSE … … 1781 1866 END SUBROUTINE iom_rp3d_sp 1782 1867 1783 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1868 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1784 1869 INTEGER , INTENT(in) :: kt ! ocean time-step 1785 1870 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1788 1873 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1789 1874 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1790 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1791 LOGICAL :: llx ! local xios write flag 1792 INTEGER :: ivid ! variable id 1793 1794 llx = .FALSE. 1795 IF(PRESENT(ldxios)) llx = ldxios 1875 ! 1876 LOGICAL :: llx ! local xios write flag 1877 INTEGER :: ivid ! variable id 1878 CHARACTER(LEN=lc) :: context 1879 ! 1880 CALL set_xios_context(kiomid, context) 1881 1882 llx = .NOT. (context == "NONE") 1883 1796 1884 IF( llx ) THEN 1797 1885 #ifdef key_iomput 1798 IF( kt == kwrite ) THEN 1799 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1800 CALL xios_send_field(trim(cdvar), pvar) 1801 ENDIF 1886 IF( kt == kwrite ) THEN 1887 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1888 CALL iom_swap(context) 1889 CALL iom_put(trim(cdvar), pvar) 1890 CALL iom_swap(cxios_context) 1891 ELSE 1892 IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 1893 CALL iom_swap(context) 1894 CALL iom_set_rstw_active( trim(cdvar), rd3 = pvar ) 1895 CALL iom_swap(cxios_context) 1896 ENDIF 1802 1897 #endif 1803 1898 ELSE … … 1865 1960 CHARACTER(LEN=*), INTENT(in) :: cdname 1866 1961 REAL(sp) , INTENT(in) :: pfield0d 1867 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1962 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1868 1963 #if defined key_iomput 1869 1964 !!clem zz(:,:)=pfield0d … … 2145 2240 CALL iom_swap( cdname ) ! swap to cdname context 2146 2241 CALL xios_update_calendar(kt) 2147 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context)) ! return back to nemo context2242 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( cxios_context ) ! return back to nemo context 2148 2243 END SUBROUTINE iom_setkt 2149 2244 … … 2159 2254 CALL iom_swap( cdname ) ! swap to cdname context 2160 2255 CALL xios_context_finalize() ! finalize the context 2161 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context)) ! return back to nemo context2256 IF( cdname /= cxios_context ) CALL iom_swap( cxios_context ) ! return back to nemo context 2162 2257 ENDIF 2163 2258 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/iom_def.F90
r13558 r13984 9 9 !!---------------------------------------------------------------------- 10 10 USE par_kind 11 USE netcdf 11 12 12 13 IMPLICIT NONE … … 36 37 INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple 37 38 !XIOS read restart 38 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS 39 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS main switch 39 40 LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file 40 LOGICAL, PUBLIC :: lxios_set = .FALSE. 41 42 41 43 42 44 TYPE, PUBLIC :: file_descriptor … … 59 61 END TYPE file_descriptor 60 62 TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files 61 INTEGER, PARAMETER, PUBLIC :: max_rst_fields = 95 !: maximum number of restart variables defined in iom_set_rst_vars62 TYPE, PUBLIC :: RST_FIELD63 CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file64 CHARACTER(len=30) :: grid = "NO_GRID"65 LOGICAL :: active =.FALSE. ! for restart write only: true - write field, false do not write field66 END TYPE RST_FIELD67 63 !$AGRIF_END_DO_NOT_TREAT 68 !69 TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields)70 64 ! 71 65 !! * Substitutions -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/iom_nf90.F90
r13286 r13984 31 31 PUBLIC iom_nf90_open , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput 32 32 PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt 33 PUBLIC iom_nf90_check 33 34 34 35 INTERFACE iom_nf90_get -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/prtctl.F90
r13286 r13984 8 8 !!---------------------------------------------------------------------- 9 9 USE dom_oce ! ocean space and time domain variables 10 USE domutl, ONLY : is_tile 10 11 USE in_out_manager ! I/O manager 11 12 USE mppini ! distributed memory computing … … 26 27 PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init 27 28 29 !! * Substitutions 30 # include "do_loop_substitute.h90" 28 31 !!---------------------------------------------------------------------- 29 32 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 35 38 SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & 36 39 & clinfo, clinfo1, clinfo2, clinfo3, kdim ) 40 !! 41 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 42 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 43 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 44 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 45 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 46 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 47 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 48 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array 49 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 50 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 51 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 52 INTEGER , INTENT(in), OPTIONAL :: kdim 53 ! 54 INTEGER :: itab2d_1, itab3d_1, itab4d_1, itab2d_2, itab3d_2 55 !! 56 IF( PRESENT(tab2d_1) ) THEN ; itab2d_1 = is_tile(tab2d_1) ; ELSE ; itab2d_1 = 0 ; ENDIF 57 IF( PRESENT(tab3d_1) ) THEN ; itab3d_1 = is_tile(tab3d_1) ; ELSE ; itab3d_1 = 0 ; ENDIF 58 IF( PRESENT(tab4d_1) ) THEN ; itab4d_1 = is_tile(tab4d_1) ; ELSE ; itab4d_1 = 0 ; ENDIF 59 IF( PRESENT(tab2d_2) ) THEN ; itab2d_2 = is_tile(tab2d_2) ; ELSE ; itab2d_2 = 0 ; ENDIF 60 IF( PRESENT(tab3d_2) ) THEN ; itab3d_2 = is_tile(tab3d_2) ; ELSE ; itab3d_2 = 0 ; ENDIF 61 62 CALL prt_ctl_t (tab2d_1, itab2d_1, tab3d_1, itab3d_1, tab4d_1, itab4d_1, tab2d_2, itab2d_2, tab3d_2, itab3d_2, & 63 & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 64 END SUBROUTINE prt_ctl 65 66 67 SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, & 68 & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 37 69 !!---------------------------------------------------------------------- 38 70 !! *** ROUTINE prt_ctl *** … … 70 102 !! clinfo3 : additional information 71 103 !!---------------------------------------------------------------------- 72 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 73 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 74 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 75 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 76 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 104 INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 105 REAL(wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 106 REAL(wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 107 REAL(wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 108 REAL(wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 109 REAL(wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 77 110 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 78 111 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 … … 106 139 107 140 ! define shoter names... 108 iis = nall_ictls(jl)109 iie = nall_ictle(jl)110 jjs = nall_jctls(jl)111 jje = nall_jctle(jl)141 iis = MAX( nall_ictls(jl), ntsi ) 142 iie = MIN( nall_ictle(jl), ntei ) 143 jjs = MAX( nall_jctls(jl), ntsj ) 144 jje = MIN( nall_jctle(jl), ntej ) 112 145 113 146 IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) … … 115 148 ENDIF 116 149 117 DO jn = 1, itra 118 119 IF( PRESENT(clinfo3) ) THEN 120 IF ( clinfo3 == 'tra-ta' ) THEN 121 zvctl1 = t_ctl(jl) 122 ELSEIF( clinfo3 == 'tra' ) THEN 123 zvctl1 = t_ctl(jl) 124 zvctl2 = s_ctl(jl) 125 ELSEIF( clinfo3 == 'dyn' ) THEN 126 zvctl1 = u_ctl(jl) 127 zvctl2 = v_ctl(jl) 150 ! Compute the sum control only where the tile domain and control print area overlap 151 IF( iie >= iis .AND. jje >= jjs ) THEN 152 DO jn = 1, itra 153 154 IF( PRESENT(clinfo3) ) THEN 155 IF ( clinfo3 == 'tra-ta' ) THEN 156 zvctl1 = t_ctl(jl) 157 ELSEIF( clinfo3 == 'tra' ) THEN 158 zvctl1 = t_ctl(jl) 159 zvctl2 = s_ctl(jl) 160 ELSEIF( clinfo3 == 'dyn' ) THEN 161 zvctl1 = u_ctl(jl) 162 zvctl2 = v_ctl(jl) 163 ELSE 164 zvctl1 = tra_ctl(jn,jl) 165 ENDIF 166 ENDIF 167 168 ! 2D arrays 169 IF( PRESENT(tab2d_1) ) THEN 170 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 171 ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) 172 ENDIF 173 ENDIF 174 IF( PRESENT(tab2d_2) ) THEN 175 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 176 ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) 177 ENDIF 178 ENDIF 179 180 ! 3D arrays 181 IF( PRESENT(tab3d_1) ) THEN 182 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 183 ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) 184 ENDIF 185 ENDIF 186 IF( PRESENT(tab3d_2) ) THEN 187 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 188 ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) 189 ENDIF 190 ENDIF 191 192 ! 4D arrays 193 IF( PRESENT(tab4d_1) ) THEN 194 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 195 ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) 196 ENDIF 197 ENDIF 198 199 ! Print the result 200 IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) 201 IF( PRESENT(clinfo3) ) THEN 202 ! 203 IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 204 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 205 ELSE 206 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1 207 ENDIF 208 ! 209 SELECT CASE( clinfo3 ) 210 CASE ( 'tra-ta' ) 211 t_ctl(jl) = zsum1 212 CASE ( 'tra' ) 213 t_ctl(jl) = zsum1 214 s_ctl(jl) = zsum2 215 CASE ( 'dyn' ) 216 u_ctl(jl) = zsum1 217 v_ctl(jl) = zsum2 218 CASE default 219 tra_ctl(jn,jl) = zsum1 220 END SELECT 221 ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 222 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 128 223 ELSE 129 zvctl1 = tra_ctl(jn,jl) 130 ENDIF 131 ENDIF 132 133 ! 2D arrays 134 IF( PRESENT(tab2d_1) ) THEN 135 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 136 ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) 137 ENDIF 138 ENDIF 139 IF( PRESENT(tab2d_2) ) THEN 140 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 141 ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) 142 ENDIF 143 ENDIF 144 145 ! 3D arrays 146 IF( PRESENT(tab3d_1) ) THEN 147 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 148 ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) 149 ENDIF 150 ENDIF 151 IF( PRESENT(tab3d_2) ) THEN 152 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 153 ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) 154 ENDIF 155 ENDIF 156 157 ! 4D arrays 158 IF( PRESENT(tab4d_1) ) THEN 159 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 160 ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) 161 ENDIF 162 ENDIF 163 164 ! Print the result 165 IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) 166 IF( PRESENT(clinfo3) ) THEN 167 ! 168 IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 169 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 170 ELSE 171 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1 172 ENDIF 173 ! 174 SELECT CASE( clinfo3 ) 175 CASE ( 'tra-ta' ) 176 t_ctl(jl) = zsum1 177 CASE ( 'tra' ) 178 t_ctl(jl) = zsum1 179 s_ctl(jl) = zsum2 180 CASE ( 'dyn' ) 181 u_ctl(jl) = zsum1 182 v_ctl(jl) = zsum2 183 CASE default 184 tra_ctl(jn,jl) = zsum1 185 END SELECT 186 ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 187 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 188 ELSE 189 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 190 ENDIF 191 192 END DO 224 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 225 ENDIF 226 227 END DO 228 ENDIF 193 229 END DO 194 230 ! 195 END SUBROUTINE prt_ctl 231 END SUBROUTINE prt_ctl_t 196 232 197 233 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/IOM/restart.F90
r13286 r13984 110 110 ELSE 111 111 #if defined key_iomput 112 cw xios_context = "rstw_"//TRIM(ADJUSTL(clkt))112 cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) 113 113 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 114 114 clpname = clname … … 116 116 clpname = TRIM(Agrif_CFixed())//"_"//clname 117 117 ENDIF 118 CALL iom_init( cwxios_context, TRIM(clpath)//TRIM(clpname), .false.)119 CALL xios_update_calendar(nitrst)118 numrow = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 119 CALL iom_init( cw_ocerst_cxt, kdid = numrow, ld_closedef = .false. ) 120 120 CALL iom_swap( cxios_context ) 121 121 #else … … 143 143 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 144 144 !!---------------------------------------------------------------------- 145 IF(lwxios) CALL iom_swap( cwxios_context ) 146 CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt , ldxios = lwxios) ! dynamics time step 147 CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables 145 CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt ) ! dynamics time step 146 IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables 148 147 149 148 IF ( .NOT. ln_diurnal_only ) THEN 150 CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) , ldxios = lwxios) ! before fields151 CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) , ldxios = lwxios)152 CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) , ldxios = lwxios)153 CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) , ldxios = lwxios)154 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , ssh(:,: ,Kbb), ldxios = lwxios)149 CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) ) ! before fields 150 CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) ) 151 CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 152 CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 153 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , ssh(:,: ,Kbb)) 155 154 ! 156 CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) , ldxios = lwxios) ! now fields157 CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) , ldxios = lwxios)158 CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) , ldxios = lwxios)159 CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) , ldxios = lwxios)160 CALL iom_rstput( kt, nitrst, numrow, 'sshn' , ssh(:,: ,Kmm), ldxios = lwxios)161 CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop , ldxios = lwxios)155 CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) ) ! now fields 156 CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) ) 157 CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 158 CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 159 CALL iom_rstput( kt, nitrst, numrow, 'sshn' , ssh(:,: ,Kmm)) 160 CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop ) 162 161 ENDIF 163 162 164 IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst, ldxios = lwxios ) 165 IF(lwxios) CALL iom_swap( cxios_context ) 163 IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) 166 164 IF( kt == nitrst ) THEN 167 165 IF(.NOT.lwxios) THEN 168 166 CALL iom_close( numrow ) ! close the restart file (only at last time step) 169 167 ELSE 170 CALL iom_context_finalize( cwxios_context ) 168 CALL iom_context_finalize( cw_ocerst_cxt ) 169 iom_file(numrow)%nfid = 0 170 numrow = 0 171 171 ENDIF 172 172 !!gm IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. … … 191 191 !! the file has already been opened 192 192 !!---------------------------------------------------------------------- 193 LOGICAL :: llok 194 CHARACTER(lc) :: clpath ! full path to ocean output restart file 193 LOGICAL :: llok 194 CHARACTER(len=lc) :: clpath ! full path to ocean output restart file 195 CHARACTER(len=lc+2) :: clpname ! file name including agrif prefix 195 196 !!---------------------------------------------------------------------- 196 197 ! … … 209 210 ! can handle checking if variable is in the restart file (there will be no need to open 210 211 ! restart) 211 IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini 212 lrxios = lrxios.AND.lxios_sini 213 212 214 IF( lrxios) THEN 213 crxios_context = 'nemo_rst' 214 IF( .NOT.lxios_set ) THEN 215 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 216 CALL iom_init( crxios_context ) 217 lxios_set = .TRUE. 218 ENDIF 219 ENDIF 220 IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN 221 CALL iom_init( crxios_context ) 222 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF' 223 lxios_set = .TRUE. 224 ENDIF 215 cr_ocerst_cxt = 'oce_rst' 216 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 217 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 218 ! clpname = cn_ocerst_in 219 ! ELSE 220 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_ocerst_in 221 ! ENDIF 222 CALL iom_init( cr_ocerst_cxt, kdid = numror, ld_closedef = .TRUE. ) 223 CALL iom_swap( cxios_context ) 224 ENDIF 225 225 226 ENDIF 226 227 … … 246 247 ! Check dynamics and tracer time-step consistency and force Euler restart if changed 247 248 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN 248 CALL iom_get( numror, 'rdt', zrdt , ldxios = lrxios)249 CALL iom_get( numror, 'rdt', zrdt ) 249 250 IF( zrdt /= rn_Dt ) THEN 250 251 IF(lwp) WRITE( numout,*) … … 256 257 ENDIF 257 258 258 CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables259 IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables 259 260 260 261 ! Diurnal DSST 261 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst , ldxios = lrxios)262 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 262 263 IF ( ln_diurnal_only ) THEN 263 264 IF(lwp) WRITE( numout, * ) & 264 265 & "rst_read:- ln_diurnal_only set, setting rhop=rho0" 265 266 rhop = rho0 266 CALL iom_get( numror, jpdom_auto, 'tn' , w3d , ldxios = lrxios)267 CALL iom_get( numror, jpdom_auto, 'tn' , w3d ) 267 268 ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) 268 269 RETURN 269 270 ENDIF 270 271 271 272 IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 272 273 ! before fields 273 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios,cd_type = 'U', psgn = -1._wp )274 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios,cd_type = 'V', psgn = -1._wp )275 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) , ldxios = lrxios)276 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) , ldxios = lrxios)277 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) , ldxios = lrxios)274 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._wp ) 275 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._wp ) 276 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 277 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 278 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) ) 278 279 ELSE 279 280 l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step … … 281 282 ! 282 283 ! now fields 283 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios,cd_type = 'U', psgn = -1._wp )284 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios,cd_type = 'V', psgn = -1._wp )285 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) , ldxios = lrxios)286 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) , ldxios = lrxios)287 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm) , ldxios = lrxios)284 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._wp ) 285 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._wp ) 286 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 287 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 288 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm) ) 288 289 IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 289 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop , ldxios = lrxios) ! now potential density290 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density 290 291 ELSE 291 292 CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ISF/isfcav.F90
r13226 r13984 183 183 ! cavity mask 184 184 mskisf_cav(:,:) = (1._wp - tmask(:,:,1)) * ssmask(:,:) 185 ! 186 !================ 187 ! 2: read restart 185 !================ 186 ! 2: activate restart 187 !================ 188 ! 189 !================ 190 ! 3: read restart 188 191 !================ 189 192 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ISF/isfcpl.F90
r13295 r13984 120 120 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 121 121 #endif 122 ! prepare writing restart123 IF( lwxios ) THEN124 CALL iom_set_rstw_var_active('ssmask')125 CALL iom_set_rstw_var_active('tmask')126 CALL iom_set_rstw_var_active('e3t_n')127 CALL iom_set_rstw_var_active('e3u_n')128 CALL iom_set_rstw_var_active('e3v_n')129 END IF130 !131 122 END SUBROUTINE isfcpl_init 132 123 ! … … 153 144 END DO 154 145 ! 155 IF( lwxios ) CALL iom_swap( cwxios_context ) 156 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios ) 157 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 158 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t , ldxios = lwxios ) 159 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u , ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v , ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 162 IF( lwxios ) CALL iom_swap( cxios_context ) 146 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask ) 147 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask ) 148 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t ) 149 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u ) 150 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v ) 151 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw ) 163 152 ! 164 153 END SUBROUTINE isfcpl_rst_write … … 183 172 !!---------------------------------------------------------------------- 184 173 ! 185 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b , ldxios = lrxios) ! need to extrapolate T/S174 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S 186 175 187 176 ! compute new ssh if we open a full water column … … 264 253 !!---------------------------------------------------------------------- 265 254 ! 266 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b , ldxios = lrxios) ! need to extrapolate T/S267 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b , ldxios = lrxios) ! need to extrapolate T/S268 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) , ldxios = lrxios) ! need to interpol vertical profile (vvl)255 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S 256 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b ) ! need to extrapolate T/S 257 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) 269 258 ! 270 259 ! … … 410 399 !!---------------------------------------------------------------------- 411 400 ! 412 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b , ldxios = lrxios)413 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios)414 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios)401 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) 402 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b ) 403 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b ) 415 404 ! 416 405 ! 1.0: compute horizontal volume flux divergence difference before-after coupling … … 520 509 521 510 ! get restart variable 522 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) , ldxios = lrxios) ! need to extrapolate T/S523 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios)524 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios)525 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios)511 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) ) ! need to extrapolate T/S 512 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) ) 513 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) ) 514 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) ) 526 515 527 516 ! compute run length -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ISF/isfrst.F90
r13286 r13984 53 53 IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 54 54 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) , ldxios = lrxios) ! before ice shelf melt56 CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) , ldxios = lrxios) ! before ice shelf heat flux57 CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) , ldxios = lrxios) ! before ice shelf heat flux55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt 56 CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) ) ! before ice shelf heat flux 57 CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) ) ! before ice shelf heat flux 58 58 ELSE 59 59 pfwf_b(:,:) = pfwf(:,:) … … 61 61 ENDIF 62 62 ! 63 IF( lwxios ) THEN64 CALL iom_set_rstw_var_active(TRIM(chc_b ))65 CALL iom_set_rstw_var_active(TRIM(csc_b ))66 CALL iom_set_rstw_var_active(TRIM(cfwf_b))67 ENDIF68 69 63 END SUBROUTINE isfrst_read 70 64 ! … … 95 89 ! 96 90 ! write restart variable 97 IF( lwxios ) CALL iom_swap( cwxios_context ) 98 CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) , ldxios = lwxios ) 99 CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem), ldxios = lwxios ) 100 CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal), ldxios = lwxios ) 101 IF( lwxios ) CALL iom_swap( cxios_context ) 91 CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) ) 92 CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem) ) 93 CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal) ) 102 94 ! 103 95 END SUBROUTINE isfrst_write -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13472 r13984 40 40 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 41 41 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 42 & , kfillmode, pfillval, lsend, lrecv )42 & , kfillmode, pfillval, lsend, lrecv, ncsten ) 43 43 !!--------------------------------------------------------------------- 44 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine … … 55 55 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 57 LOGICAL , OPTIONAL , INTENT(in ) :: ncsten 57 58 !! 58 59 INTEGER :: kfld ! number of elements that will be attributed … … 84 85 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 85 86 ! 86 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv )87 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 87 88 ! 88 89 END SUBROUTINE ROUTINE_MULTI -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LBC/lbclnk.F90
r13226 r13984 39 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 40 40 END INTERFACE 41 INTERFACE lbc_lnk_nc_multi 42 MODULE PROCEDURE lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 43 MODULE PROCEDURE lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 44 END INTERFACE 45 INTERFACE lbc_lnk_nc 46 MODULE PROCEDURE mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 47 MODULE PROCEDURE mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 48 END INTERFACE 41 49 ! 42 50 INTERFACE lbc_lnk_icb … … 52 60 END INTERFACE 53 61 54 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 55 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 56 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 62 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 63 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 64 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 65 PUBLIC lbc_lnk_nc ! ocean/ice lateral boundary conditions (MPI3 version) 66 PUBLIC lbc_lnk_nc_multi ! modified ocean/ice lateral boundary conditions (MPI3 version) 57 67 58 68 #if defined key_mpp_mpi … … 250 260 # undef DIM_4d 251 261 262 !!---------------------------------------------------------------------- 263 !! *** load_ptr_(2,3,4)d *** 264 !! 265 !! * Dummy Argument : 266 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 267 !! cd_nat ! nature of pt2d array grid-points 268 !! psgn ! sign used across the north fold boundary 269 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 270 !! cdna_ptr ! nature of ptab array grid-points 271 !! psgn_ptr ! sign used across the north fold boundary 272 !! kfld ! number of elements that has been attributed 273 !!---------------------------------------------------------------------- 274 275 !!---------------------------------------------------------------------- 276 !! *** lbc_lnk_nc(2,3,4)d_multi *** 277 !! *** load_ptr_(2,3,4)d *** 278 !! 279 !! * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 280 !! 281 !!---------------------------------------------------------------------- 282 283 !! 284 !! ---- SINGLE PRECISION VERSIONS 285 !! 286 # define SINGLE_PRECISION 287 # define DIM_2d 288 # define ROUTINE_NC_LOAD load_ptr_nc_2d_sp 289 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_sp 290 # include "lbc_lnk_nc_generic.h90" 291 # undef ROUTINE_MULTI_NC 292 # undef ROUTINE_NC_LOAD 293 # undef DIM_2d 294 295 # define DIM_3d 296 # define ROUTINE_NC_LOAD load_ptr_nc_3d_sp 297 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_sp 298 # include "lbc_lnk_nc_generic.h90" 299 # undef ROUTINE_MULTI_NC 300 # undef ROUTINE_NC_LOAD 301 # undef DIM_3d 302 303 # define DIM_4d 304 # define ROUTINE_NC_LOAD load_ptr_nc_4d_sp 305 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_sp 306 # include "lbc_lnk_nc_generic.h90" 307 # undef ROUTINE_MULTI_NC 308 # undef ROUTINE_NC_LOAD 309 # undef DIM_4d 310 # undef SINGLE_PRECISION 311 !! 312 !! ---- DOUBLE PRECISION VERSIONS 313 !! 314 315 # define DIM_2d 316 # define ROUTINE_NC_LOAD load_ptr_nc_2d_dp 317 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_dp 318 # include "lbc_lnk_nc_generic.h90" 319 # undef ROUTINE_MULTI_NC 320 # undef ROUTINE_NC_LOAD 321 # undef DIM_2d 322 323 # define DIM_3d 324 # define ROUTINE_NC_LOAD load_ptr_nc_3d_dp 325 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_dp 326 # include "lbc_lnk_nc_generic.h90" 327 # undef ROUTINE_MULTI_NC 328 # undef ROUTINE_NC_LOAD 329 # undef DIM_3d 330 331 # define DIM_4d 332 # define ROUTINE_NC_LOAD load_ptr_nc_4d_dp 333 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_dp 334 # include "lbc_lnk_nc_generic.h90" 335 # undef ROUTINE_MULTI_NC 336 # undef ROUTINE_NC_LOAD 337 # undef DIM_4d 338 339 !!---------------------------------------------------------------------- 340 !! *** routine mpp_lnk_nc_(2,3,4)d *** 341 !! 342 !! * Argument : dummy argument use in mpp_lnk_... routines 343 !! ptab : array or pointer of arrays on which the boundary condition is applied 344 !! cd_nat : nature of array grid-points 345 !! psgn : sign used across the north fold boundary 346 !! kfld : optional, number of pt3d arrays 347 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 348 !! pfillval : optional, background value (used with jpfillcopy) 349 !!---------------------------------------------------------------------- 350 ! 351 ! !== 2D array and array of 2D pointer ==! 352 ! 353 !! 354 !! ---- SINGLE PRECISION VERSIONS 355 !! 356 # define SINGLE_PRECISION 357 # define DIM_2d 358 # define ROUTINE_NC mpp_lnk_nc_2d_sp 359 # include "mpp_nc_generic.h90" 360 # undef ROUTINE_NC 361 # undef DIM_2d 362 ! 363 ! !== 3D array and array of 3D pointer ==! 364 ! 365 # define DIM_3d 366 # define ROUTINE_NC mpp_lnk_nc_3d_sp 367 # include "mpp_nc_generic.h90" 368 # undef ROUTINE_NC 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_NC mpp_lnk_nc_4d_sp 375 # include "mpp_nc_generic.h90" 376 # undef ROUTINE_NC 377 # undef DIM_4d 378 # undef SINGLE_PRECISION 379 380 !! 381 !! ---- DOUBLE PRECISION VERSIONS 382 !! 383 # define DIM_2d 384 # define ROUTINE_NC mpp_lnk_nc_2d_dp 385 # include "mpp_nc_generic.h90" 386 # undef ROUTINE_NC 387 # undef DIM_2d 388 ! 389 ! !== 3D array and array of 3D pointer ==! 390 ! 391 # define DIM_3d 392 # define ROUTINE_NC mpp_lnk_nc_3d_dp 393 # include "mpp_nc_generic.h90" 394 # undef ROUTINE_NC 395 # undef DIM_3d 396 ! 397 ! !== 4D array and array of 4D pointer ==! 398 ! 399 # define DIM_4d 400 # define ROUTINE_NC mpp_lnk_nc_4d_dp 401 # include "mpp_nc_generic.h90" 402 # undef ROUTINE_NC 403 # undef DIM_4d 252 404 253 405 !!---------------------------------------------------------------------- -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LBC/lib_mpp.F90
r13636 r13984 66 66 PUBLIC mppscatter, mppgather 67 67 PUBLIC mpp_ini_znl 68 PUBLIC mpp_ini_nc 68 69 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 69 70 PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines … … 137 138 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 138 139 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 140 141 ! variables used for MPI3 neighbourhood collectives 142 INTEGER, PUBLIC :: mpi_nc_com ! MPI3 neighbourhood collectives communicator 143 INTEGER, PUBLIC :: mpi_nc_all_com ! MPI3 neighbourhood collectives communicator (with diagionals) 139 144 140 145 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 1067 1072 1068 1073 END SUBROUTINE mpp_ini_znl 1074 1075 SUBROUTINE mpp_ini_nc 1076 !!---------------------------------------------------------------------- 1077 !! *** routine mpp_ini_nc *** 1078 !! 1079 !! ** Purpose : Initialize special communicators for MPI3 neighbourhood 1080 !! collectives 1081 !! 1082 !! ** Method : - Create graph communicators starting from the processes 1083 !! distribution along i and j directions 1084 ! 1085 !! ** output 1086 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1087 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1088 !! (with diagonals) 1089 !! 1090 !!---------------------------------------------------------------------- 1091 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1092 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1093 INTEGER :: ierr 1094 LOGICAL, PARAMETER :: ireord = .FALSE. 1095 1096 #if defined key_mpp_mpi 1097 1098 ideg = 0 1099 idegalls = 0 1100 idegallr = 0 1101 icont = 0 1102 icont1 = 0 1103 1104 IF (nbondi .eq. 1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. -1) THEN 1107 ideg = ideg + 1 1108 ELSEIF (nbondi .eq. 0) THEN 1109 ideg = ideg + 2 1110 ENDIF 1111 1112 IF (nbondj .eq. 1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. -1) THEN 1115 ideg = ideg + 1 1116 ELSEIF (nbondj .eq. 0) THEN 1117 ideg = ideg + 2 1118 ENDIF 1119 1120 idegalls = ideg 1121 idegallr = ideg 1122 1123 IF (nones .ne. -1) idegalls = idegalls + 1 1124 IF (nonws .ne. -1) idegalls = idegalls + 1 1125 IF (noses .ne. -1) idegalls = idegalls + 1 1126 IF (nosws .ne. -1) idegalls = idegalls + 1 1127 IF (noner .ne. -1) idegallr = idegallr + 1 1128 IF (nonwr .ne. -1) idegallr = idegallr + 1 1129 IF (noser .ne. -1) idegallr = idegallr + 1 1130 IF (noswr .ne. -1) idegallr = idegallr + 1 1131 1132 ALLOCATE(ineigh(ideg)) 1133 ALLOCATE(ineighalls(idegalls)) 1134 ALLOCATE(ineighallr(idegallr)) 1135 1136 IF (nbondi .eq. 1) THEN 1137 icont = icont + 1 1138 ineigh(icont) = nowe 1139 ineighalls(icont) = nowe 1140 ineighallr(icont) = nowe 1141 ELSEIF (nbondi .eq. -1) THEN 1142 icont = icont + 1 1143 ineigh(icont) = noea 1144 ineighalls(icont) = noea 1145 ineighallr(icont) = noea 1146 ELSEIF (nbondi .eq. 0) THEN 1147 icont = icont + 1 1148 ineigh(icont) = nowe 1149 ineighalls(icont) = nowe 1150 ineighallr(icont) = nowe 1151 icont = icont + 1 1152 ineigh(icont) = noea 1153 ineighalls(icont) = noea 1154 ineighallr(icont) = noea 1155 ENDIF 1156 1157 IF (nbondj .eq. 1) THEN 1158 icont = icont + 1 1159 ineigh(icont) = noso 1160 ineighalls(icont) = noso 1161 ineighallr(icont) = noso 1162 ELSEIF (nbondj .eq. -1) THEN 1163 icont = icont + 1 1164 ineigh(icont) = nono 1165 ineighalls(icont) = nono 1166 ineighallr(icont) = nono 1167 ELSEIF (nbondj .eq. 0) THEN 1168 icont = icont + 1 1169 ineigh(icont) = noso 1170 ineighalls(icont) = noso 1171 ineighallr(icont) = noso 1172 icont = icont + 1 1173 ineigh(icont) = nono 1174 ineighalls(icont) = nono 1175 ineighallr(icont) = nono 1176 ENDIF 1177 1178 icont1 = icont 1179 IF (nosws .ne. -1) THEN 1180 icont = icont + 1 1181 ineighalls(icont) = nosws 1182 ENDIF 1183 IF (noses .ne. -1) THEN 1184 icont = icont + 1 1185 ineighalls(icont) = noses 1186 ENDIF 1187 IF (nonws .ne. -1) THEN 1188 icont = icont + 1 1189 ineighalls(icont) = nonws 1190 ENDIF 1191 IF (nones .ne. -1) THEN 1192 icont = icont + 1 1193 ineighalls(icont) = nones 1194 ENDIF 1195 IF (noswr .ne. -1) THEN 1196 icont1 = icont1 + 1 1197 ineighallr(icont1) = noswr 1198 ENDIF 1199 IF (noser .ne. -1) THEN 1200 icont1 = icont1 + 1 1201 ineighallr(icont1) = noser 1202 ENDIF 1203 IF (nonwr .ne. -1) THEN 1204 icont1 = icont1 + 1 1205 ineighallr(icont1) = nonwr 1206 ENDIF 1207 IF (noner .ne. -1) THEN 1208 icont1 = icont1 + 1 1209 ineighallr(icont1) = noner 1210 ENDIF 1211 1212 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 1213 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 1214 1215 DEALLOCATE (ineigh) 1216 DEALLOCATE (ineighalls) 1217 DEALLOCATE (ineighallr) 1218 #endif 1219 END SUBROUTINE mpp_ini_nc 1220 1069 1221 1070 1222 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LBC/mpp_lnk_generic.h90
r13286 r13984 72 72 73 73 #if defined MULTI 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 75 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 76 76 #else 77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv )77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ncsten ) 78 78 #endif 79 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 84 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil 86 87 ! 87 88 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 100 101 !!---------------------------------------------------------------------- 101 102 ! 103 #if defined key_mpi3 104 # if defined MULTI 105 CALL lbc_lnk_nc ( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 106 # else 107 CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten) 108 # endif 109 #else 110 102 111 ! ----------------------------------------- ! 103 112 ! 0. local variables initialization ! … … 387 396 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 388 397 ! 398 #endif 389 399 END SUBROUTINE ROUTINE_LNK 390 400 #undef PRECISION -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LBC/mppini.F90
r13490 r13984 542 542 ij = ijn(narea) 543 543 ! 544 ! set default neighbours545 noso = ii_noso(narea)546 nowe = ii_nowe(narea)547 noea = ii_noea(narea)548 nono = ii_nono(narea)549 544 jpi = ijpi(ii,ij) 550 545 !!$ Nis0 = iis0(ii,ij) … … 558 553 njmpp = ijmppt(ii,ij) 559 554 jpk = jpkglo ! third dim 555 556 ! set default neighbours 557 noso = ii_noso(narea) 558 nowe = ii_nowe(narea) 559 noea = ii_noea(narea) 560 nono = ii_nono(narea) 561 562 nones = -1 563 nonws = -1 564 noses = -1 565 nosws = -1 566 567 noner = -1 568 nonwr = -1 569 noser = -1 570 noswr = -1 571 572 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 573 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 574 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 575 noses = ii_noso(noea+1) 576 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 577 nones = ii_nono(noea+1) ! east neighbour has north neighbour 578 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 579 noses = ii_noso(noea+1) ! east neighbour has south neighbour 580 END IF 581 END IF 582 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 583 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 584 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 585 nosws = ii_noso(nowe+1) 586 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 587 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 588 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 589 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 590 END IF 591 END IF 592 593 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 594 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 595 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 596 nonwr = ii_nowe(nono+1) 597 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 598 noner = ii_noea(nono+1) ! north neighbour has east neighbour 599 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 600 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 601 END IF 602 END IF 603 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 604 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 605 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 606 noswr = ii_nowe(noso+1) 607 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 608 noser = ii_noea(noso+1) ! south neighbour has east neighbour 609 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 610 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 611 END IF 612 END IF 613 560 614 ! 561 615 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) … … 648 702 ENDIF 649 703 ENDIF 704 705 ! 706 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 650 707 ! 651 708 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LDF/ldfc1d_c2d.F90
r13497 r13984 140 140 END_2D 141 141 CASE( 'TRA' ) ! U- and V-points 142 DO_2D( 1, 1, 1, 1 ) 142 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 143 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 143 144 pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn 144 145 pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/LDF/ldftra.F90
r13558 r13984 427 427 zaht_min = 0.2_wp * aht0 ! minimum value for aht 428 428 zDaht = aht0 - zaht_min 429 DO_2D( 1, 1, 1, 1 ) 429 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 430 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 430 431 !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) 431 432 !! ==>>> The Coriolis value is identical for t- & u_points, and for v- and f-points … … 725 726 !! ** Action : pu, pv increased by the eiv transport 726 727 !!---------------------------------------------------------------------- 727 INTEGER 728 INTEGER 729 INTEGER 730 CHARACTER(len=3) 731 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pu! in : 3 ocean transport components [m3/s]732 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pv! out: 3 ocean transport components [m3/s]733 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pw! increased by the eiv [m3/s]728 INTEGER , INTENT(in ) :: kt ! ocean time-step index 729 INTEGER , INTENT(in ) :: kit000 ! first time step index 730 INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices 731 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 732 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] 733 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] 734 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] 734 735 !! 735 736 INTEGER :: ji, jj, jk ! dummy loop indices 736 737 REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars 737 738 REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - 738 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 739 !!---------------------------------------------------------------------- 740 ! 741 IF( kt == kit000 ) THEN 742 IF(lwp) WRITE(numout,*) 743 IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 744 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' 739 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 740 !!---------------------------------------------------------------------- 741 ! 742 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 743 IF( kt == kit000 ) THEN 744 IF(lwp) WRITE(numout,*) 745 IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 746 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' 747 ENDIF 745 748 ENDIF 746 749 … … 781 784 !! 782 785 !!---------------------------------------------------------------------- 783 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: psi_uw, psi_vw ! streamfunction [m3/s]784 INTEGER 786 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: psi_uw, psi_vw ! streamfunction [m3/s] 787 INTEGER , INTENT(in ) :: Kmm ! ocean time level indices 785 788 ! 786 789 INTEGER :: ji, jj, jk ! dummy loop indices 787 790 REAL(wp) :: zztmp ! local scalar 788 REAL(wp), DIMENSION( jpi,jpj) :: zw2d ! 2D workspace789 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zw3d ! 3D workspace791 REAL(wp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace 792 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace 790 793 !!---------------------------------------------------------------------- 791 794 ! … … 793 796 !!gm to be redesigned.... 794 797 ! !== eiv stream function: output ==! 795 CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp )796 !797 798 !!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output 798 799 !!gm CALL iom_put( "psi_eiv_vw", psi_vw ) … … 802 803 zw3d(:,:,jpk) = 0._wp ! bottom value always 0 803 804 ! 804 DO jk = 1, jpkm1! e2u e3u u_eiv = -dk[psi_uw]805 zw3d( :,:,jk) = ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) / ( e2u(:,:) * e3u(:,:,jk,Kmm) )806 END DO805 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw] 806 zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) ) 807 END_3D 807 808 CALL iom_put( "uoce_eiv", zw3d ) 808 809 ! 809 DO jk = 1, jpkm1! e1v e3v v_eiv = -dk[psi_vw]810 zw3d( :,:,jk) = ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) / ( e1v(:,:) * e3v(:,:,jk,Kmm) )811 END DO810 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw] 811 zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) ) 812 END_3D 812 813 CALL iom_put( "voce_eiv", zw3d ) 813 814 ! … … 816 817 & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) 817 818 END_3D 818 CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp ) ! lateral boundary condition819 819 CALL iom_put( "woce_eiv", zw3d ) 820 820 ! 821 821 IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value 822 zw2d(:,:) = rho0 * e1e2t(:,:) 822 DO_2D( 0, 0, 0, 0 ) 823 zw2d(ji,jj) = rho0 * e1e2t(ji,jj) 824 END_2D 823 825 DO jk = 1, jpk 824 826 zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) … … 844 846 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 845 847 END_3D 846 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )847 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )848 848 CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction 849 849 CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction … … 865 865 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 866 866 END_3D 867 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 868 CALL iom_put( "veiv_heattr", zztmp * zw2d ) ! heat transport in j-direction 869 CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction 867 CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction 868 CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction 870 869 ! 871 870 IF( iom_use( 'sophteiv' ) ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) … … 880 879 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 881 880 END_3D 882 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )883 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )884 881 CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction 885 882 CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction … … 892 889 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 893 890 END_3D 894 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 895 CALL iom_put( "veiv_salttr", zztmp * zw2d ) ! salt transport in j-direction 896 CALL iom_put( "veiv_salttr", zztmp * zw3d ) ! salt transport in j-direction 891 CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction 892 CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction 897 893 ! 898 894 IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/SBC/sbcapr.F90
r13286 r13984 65 65 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 66 66 TYPE(FLD_N) :: sn_apr ! informations about the fields to be read 67 LOGICAL :: lrxios ! read restart using XIOS?68 67 !! 69 68 NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc … … 108 107 CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 109 108 ! 110 IF( lwxios ) THEN111 CALL iom_set_rstw_var_active('ssh_ibb')112 ENDIF113 109 END SUBROUTINE sbc_apr_init 114 110 … … 154 150 IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN 155 151 IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' 156 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb , ldxios = lrxios) ! before inv. barometer ssh152 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh 157 153 ! 158 154 ELSE !* no restart: set from nit000 values … … 167 163 IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp 168 164 IF(lwp) WRITE(numout,*) '~~~~' 169 IF( lwxios ) CALL iom_swap( cwxios_context ) 170 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib, ldxios = lwxios ) 171 IF( lwxios ) CALL iom_swap( cxios_context ) 165 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib ) 172 166 ENDIF 173 167 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/SBC/sbcflx.F90
r13497 r13984 127 127 128 128 IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle 129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask( ji,jj,1)129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 130 130 ELSE 131 131 DO_2D( 0, 0, 0, 0 ) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/SBC/sbcmod.F90
r13722 r13984 359 359 IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation 360 360 ! 361 IF( lwxios ) THEN362 CALL iom_set_rstw_var_active('utau_b')363 CALL iom_set_rstw_var_active('vtau_b')364 CALL iom_set_rstw_var_active('qns_b')365 ! The 3D heat content due to qsr forcing is treated in traqsr366 ! CALL iom_set_rstw_var_active('qsr_b')367 CALL iom_set_rstw_var_active('emp_b')368 CALL iom_set_rstw_var_active('sfx_b')369 ENDIF370 371 361 END SUBROUTINE sbc_init 372 362 … … 510 500 & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 511 501 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' 512 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b , ldxios = lrxios, cd_type = 'U', psgn = -1._wp) ! before i-stress (U-point)513 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b , ldxios = lrxios, cd_type = 'V', psgn = -1._wp) ! before j-stress (V-point)514 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b , ldxios = lrxios) ! before non solar heat flux (T-point)502 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! before i-stress (U-point) 503 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! before j-stress (V-point) 504 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! before non solar heat flux (T-point) 515 505 ! The 3D heat content due to qsr forcing is treated in traqsr 516 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b , ldxios = lrxios) ! before solar heat flux (T-point)517 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b , ldxios = lrxios) ! before freshwater flux (T-point)506 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b ) ! before solar heat flux (T-point) 507 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! before freshwater flux (T-point) 518 508 ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 519 509 IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN 520 CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b , ldxios = lrxios) ! before salt flux (T-point)510 CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b ) ! before salt flux (T-point) 521 511 ELSE 522 512 sfx_b (:,:) = sfx(:,:) … … 538 528 & 'at it= ', kt,' date= ', ndastp 539 529 IF(lwp) WRITE(numout,*) '~~~~' 540 IF( lwxios ) CALL iom_swap( cwxios_context ) 541 CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios ) 542 CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios ) 543 CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns, ldxios = lwxios ) 530 CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) 531 CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) 532 CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns ) 544 533 ! The 3D heat content due to qsr forcing is treated in traqsr 545 534 ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr ) 546 CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp, ldxios = lwxios ) 547 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx, ldxios = lwxios ) 548 IF( lwxios ) CALL iom_swap( cxios_context ) 535 CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp ) 536 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 549 537 ENDIF 550 538 ! ! ---------------------------------------- ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/SBC/sbcrnf.F90
r13497 r13984 160 160 & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 161 161 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios 162 CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b , ldxios = lrxios) ! before runoff163 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) , ldxios = lrxios) ! before heat content of runoff164 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) , ldxios = lrxios) ! before salinity content of runoff162 CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b ) ! before runoff 163 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff 164 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff 165 165 ELSE !* no restart: set from nit000 values 166 166 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' … … 176 176 & 'at it= ', kt,' date= ', ndastp 177 177 IF(lwp) WRITE(numout,*) '~~~~' 178 IF( lwxios ) CALL iom_swap( cwxios_context ) 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios ) 180 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios ) 181 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios ) 182 IF( lwxios ) CALL iom_swap( cxios_context ) 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 180 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 183 181 ENDIF 184 182 ! … … 480 478 ENDIF 481 479 ! 482 IF( lwxios ) THEN483 CALL iom_set_rstw_var_active('rnf_b')484 CALL iom_set_rstw_var_active('rnf_hc_b')485 CALL iom_set_rstw_var_active('rnf_sc_b')486 ENDIF487 488 480 END SUBROUTINE sbc_rnf_init 489 481 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/SBC/sbcssm.F90
r13286 r13984 154 154 IF(lwp) WRITE(numout,*) '~~~~~~~' 155 155 zf_sbc = REAL( nn_fsbc, wp ) 156 IF( lwxios ) CALL iom_swap( cwxios_context ) 157 CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc, ldxios = lwxios ) ! sbc frequency 158 CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m, ldxios = lwxios ) ! sea surface mean fields 159 CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m, ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m, ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m, ldxios = lwxios ) 162 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m, ldxios = lwxios ) 163 CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m, ldxios = lwxios ) 164 CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m, ldxios = lwxios ) 165 ! 166 IF( lwxios ) CALL iom_swap( cxios_context ) 156 CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc ) ! sbc frequency 157 CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m ) ! sea surface mean fields 158 CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m ) 159 CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m ) 160 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) 161 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) 162 CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m ) 163 CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m ) 164 ! 167 165 ENDIF 168 166 ! … … 208 206 IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN 209 207 l_ssm_mean = .TRUE. 210 CALL iom_get( numror , 'nn_fsbc', zf_sbc ,ldxios = lrxios) ! sbc frequency of previous run211 CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, ldxios = lrxios,cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point)212 CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, ldxios = lrxios,cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point)213 CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m , ldxios = lrxios) ! " " temperature (T-point)214 CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m , ldxios = lrxios) ! " " salinity (T-point)215 CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m , ldxios = lrxios) ! " " height (T-point)216 CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m , ldxios = lrxios) ! 1st level thickness (T-point)208 CALL iom_get( numror , 'nn_fsbc', zf_sbc ) ! sbc frequency of previous run 209 CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point) 210 CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point) 211 CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m ) ! " " temperature (T-point) 212 CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m ) ! " " salinity (T-point) 213 CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m ) ! " " height (T-point) 214 CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m ) ! 1st level thickness (T-point) 217 215 ! fraction of solar net radiation absorbed in 1st T level 218 216 IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 219 CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m , ldxios = lrxios)217 CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m ) 220 218 ELSE 221 219 frq_m(:,:) = 1._wp ! default definition … … 255 253 IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level 256 254 ! 257 IF( lwxios.AND.nn_fsbc > 1 ) THEN258 CALL iom_set_rstw_var_active('nn_fsbc')259 CALL iom_set_rstw_var_active('ssu_m')260 CALL iom_set_rstw_var_active('ssv_m')261 CALL iom_set_rstw_var_active('sst_m')262 CALL iom_set_rstw_var_active('sss_m')263 CALL iom_set_rstw_var_active('ssh_m')264 CALL iom_set_rstw_var_active('e3t_m')265 CALL iom_set_rstw_var_active('frq_m')266 ENDIF267 268 255 END SUBROUTINE sbc_ssm_init 269 256 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/eosbn2.F90
r13497 r13984 39 39 !!---------------------------------------------------------------------- 40 40 USE dom_oce ! ocean space and time domain 41 USE domutl, ONLY : is_tile 41 42 USE phycst ! physical constants 42 43 USE stopar ! Stochastic T/S fluctuations … … 189 190 190 191 SUBROUTINE eos_insitu( pts, prd, pdep ) 192 !! 193 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 194 ! ! 2 : salinity [psu] 195 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 196 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 197 !! 198 CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) 199 END SUBROUTINE eos_insitu 200 201 SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) 191 202 !!---------------------------------------------------------------------- 192 203 !! *** ROUTINE eos_insitu *** … … 222 233 !! TEOS-10 Manual, 2010 223 234 !!---------------------------------------------------------------------- 224 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 225 ! ! 2 : salinity [psu] 226 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 227 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 235 INTEGER , INTENT(in ) :: ktts, ktrd, ktdep 236 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 237 ! ! 2 : salinity [psu] 238 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 239 REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] 228 240 ! 229 241 INTEGER :: ji, jj, jk ! dummy loop indices … … 238 250 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 239 251 ! 240 DO_3D( 1, 1, 1, 1, 1, jpkm1 )252 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 241 253 ! 242 254 zh = pdep(ji,jj,jk) * r1_Z0 ! depth … … 274 286 CASE( np_seos ) !== simplified EOS ==! 275 287 ! 276 DO_3D( 1, 1, 1, 1, 1, jpkm1 )288 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 277 289 zt = pts (ji,jj,jk,jp_tem) - 10._wp 278 290 zs = pts (ji,jj,jk,jp_sal) - 35._wp … … 293 305 IF( ln_timing ) CALL timing_stop('eos-insitu') 294 306 ! 295 END SUBROUTINE eos_insitu 307 END SUBROUTINE eos_insitu_t 296 308 297 309 298 310 SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 311 !! 312 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 313 ! ! 2 : salinity [psu] 314 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 315 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) 316 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 317 !! 318 CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) 319 END SUBROUTINE eos_insitu_pot 320 321 322 SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) 299 323 !!---------------------------------------------------------------------- 300 324 !! *** ROUTINE eos_insitu_pot *** … … 309 333 !! 310 334 !!---------------------------------------------------------------------- 311 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 312 ! ! 2 : salinity [psu] 313 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 314 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) 315 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 335 INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep 336 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 337 ! ! 2 : salinity [psu] 338 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 339 REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) 340 REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] 316 341 ! 317 342 INTEGER :: ji, jj, jk, jsmp ! dummy loop indices … … 338 363 END DO 339 364 ! 340 DO_3D( 1, 1, 1, 1, 1, jpkm1 )365 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 341 366 ! 342 367 ! compute density (2*nn_sto_eos) times: … … 388 413 ! Non-stochastic equation of state 389 414 ELSE 390 DO_3D( 1, 1, 1, 1, 1, jpkm1 )415 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 391 416 ! 392 417 zh = pdep(ji,jj,jk) * r1_Z0 ! depth … … 426 451 CASE( np_seos ) !== simplified EOS ==! 427 452 ! 428 DO_3D( 1, 1, 1, 1, 1, jpkm1 )453 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 429 454 zt = pts (ji,jj,jk,jp_tem) - 10._wp 430 455 zs = pts (ji,jj,jk,jp_sal) - 35._wp … … 444 469 END SELECT 445 470 ! 446 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 471 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', & 472 & tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 447 473 ! 448 474 IF( ln_timing ) CALL timing_stop('eos-pot') 449 475 ! 450 END SUBROUTINE eos_insitu_pot 476 END SUBROUTINE eos_insitu_pot_t 451 477 452 478 453 479 SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 480 !! 481 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 482 ! ! 2 : salinity [psu] 483 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 484 REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density 485 !! 486 CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) 487 END SUBROUTINE eos_insitu_2d 488 489 490 SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) 454 491 !!---------------------------------------------------------------------- 455 492 !! *** ROUTINE eos_insitu_2d *** … … 462 499 !! 463 500 !!---------------------------------------------------------------------- 464 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 465 ! ! 2 : salinity [psu] 466 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 467 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: prd ! in situ density 501 INTEGER , INTENT(in ) :: ktts, ktdep, ktrd 502 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 503 ! ! 2 : salinity [psu] 504 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 505 REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density 468 506 ! 469 507 INTEGER :: ji, jj, jk ! dummy loop indices … … 480 518 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 481 519 ! 482 DO_2D( 1, 1, 1, 1)520 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 483 521 ! 484 522 zh = pdep(ji,jj) * r1_Z0 ! depth … … 515 553 CASE( np_seos ) !== simplified EOS ==! 516 554 ! 517 DO_2D( 1, 1, 1, 1)555 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 518 556 ! 519 557 zt = pts (ji,jj,jp_tem) - 10._wp … … 535 573 IF( ln_timing ) CALL timing_stop('eos2d') 536 574 ! 537 END SUBROUTINE eos_insitu_2d 575 END SUBROUTINE eos_insitu_2d_t 538 576 539 577 540 578 SUBROUTINE rab_3d( pts, pab, Kmm ) 579 !! 580 INTEGER , INTENT(in ) :: Kmm ! time level index 581 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 582 REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 583 !! 584 CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 585 END SUBROUTINE rab_3d 586 587 588 SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 541 589 !!---------------------------------------------------------------------- 542 590 !! *** ROUTINE rab_3d *** … … 548 596 !! ** Action : - pab : thermal/haline expansion ratio at T-points 549 597 !!---------------------------------------------------------------------- 550 INTEGER , INTENT(in ) :: Kmm ! time level index 551 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 552 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 598 INTEGER , INTENT(in ) :: Kmm ! time level index 599 INTEGER , INTENT(in ) :: ktts, ktab 600 REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 601 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 553 602 ! 554 603 INTEGER :: ji, jj, jk ! dummy loop indices … … 563 612 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 564 613 ! 565 DO_3D( 1, 1, 1, 1, 1, jpkm1 )614 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 566 615 ! 567 616 zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth … … 616 665 CASE( np_seos ) !== simplified EOS ==! 617 666 ! 618 DO_3D( 1, 1, 1, 1, 1, jpkm1 )667 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 619 668 zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 620 669 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) … … 641 690 IF( ln_timing ) CALL timing_stop('rab_3d') 642 691 ! 643 END SUBROUTINE rab_3d 692 END SUBROUTINE rab_3d_t 644 693 645 694 646 695 SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 696 !! 697 INTEGER , INTENT(in ) :: Kmm ! time level index 698 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 699 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 700 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 701 !! 702 CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 703 END SUBROUTINE rab_2d 704 705 706 SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 647 707 !!---------------------------------------------------------------------- 648 708 !! *** ROUTINE rab_2d *** … … 652 712 !! ** Action : - pab : thermal/haline expansion ratio at T-points 653 713 !!---------------------------------------------------------------------- 654 INTEGER , INTENT(in ) :: Kmm ! time level index 655 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 656 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 657 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 714 INTEGER , INTENT(in ) :: Kmm ! time level index 715 INTEGER , INTENT(in ) :: ktts, ktdep, ktab 716 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 717 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 718 REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 658 719 ! 659 720 INTEGER :: ji, jj, jk ! dummy loop indices … … 670 731 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 671 732 ! 672 DO_2D( 1, 1, 1, 1)733 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 673 734 ! 674 735 zh = pdep(ji,jj) * r1_Z0 ! depth … … 723 784 CASE( np_seos ) !== simplified EOS ==! 724 785 ! 725 DO_2D( 1, 1, 1, 1)786 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 726 787 ! 727 788 zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) … … 748 809 IF( ln_timing ) CALL timing_stop('rab_2d') 749 810 ! 750 END SUBROUTINE rab_2d 811 END SUBROUTINE rab_2d_t 751 812 752 813 … … 849 910 850 911 SUBROUTINE bn2( pts, pab, pn2, Kmm ) 912 !! 913 INTEGER , INTENT(in ) :: Kmm ! time level index 914 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 915 REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 916 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 917 !! 918 CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 919 END SUBROUTINE bn2 920 921 922 SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 851 923 !!---------------------------------------------------------------------- 852 924 !! *** ROUTINE bn2 *** … … 862 934 !! 863 935 !!---------------------------------------------------------------------- 864 INTEGER , INTENT(in ) :: Kmm ! time level index 865 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 866 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 867 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 936 INTEGER , INTENT(in ) :: Kmm ! time level index 937 INTEGER , INTENT(in ) :: ktab, ktn2 938 REAL(wp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 939 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 940 REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 868 941 ! 869 942 INTEGER :: ji, jj, jk ! dummy loop indices … … 873 946 IF( ln_timing ) CALL timing_start('bn2') 874 947 ! 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90948 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 876 949 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 877 950 & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) … … 889 962 IF( ln_timing ) CALL timing_stop('bn2') 890 963 ! 891 END SUBROUTINE bn2 964 END SUBROUTINE bn2_t 892 965 893 966 … … 949 1022 950 1023 951 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 1024 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 1025 !! 1026 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 1027 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1028 REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] 1029 !! 1030 CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 1031 END SUBROUTINE eos_fzp_2d 1032 1033 1034 SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) 952 1035 !!---------------------------------------------------------------------- 953 1036 !! *** ROUTINE eos_fzp *** … … 961 1044 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 962 1045 !!---------------------------------------------------------------------- 963 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 964 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 965 REAL(wp), DIMENSION(jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celsius] 1046 INTEGER , INTENT(in ) :: kttf 1047 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] 1048 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] 1049 REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] 966 1050 ! 967 1051 INTEGER :: ji, jj ! dummy loop indices … … 996 1080 END SELECT 997 1081 ! 998 END SUBROUTINE eos_fzp_2d 1082 END SUBROUTINE eos_fzp_2d_t 999 1083 1000 1084 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv.F90
r13237 r13984 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 ! TEMP: [tiling] This change not necessary after extended haloes development 21 USE domain, ONLY : dom_tile 20 22 USE domvvl ! variable vertical scale factors 21 23 USE sbcwave ! wave module … … 23 25 USE traadv_cen ! centered scheme (tra_adv_cen routine) 24 26 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 27 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version) 25 28 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 29 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version) 26 30 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 27 31 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 65 69 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 70 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 67 71 72 !! * Substitutions 73 # include "do_loop_substitute.h90" 68 74 # include "domzgr_substitute.h90" 69 75 !!---------------------------------------------------------------------- … … 86 92 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 87 93 ! 88 INTEGER :: jk ! dummy loop index 89 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zuu, zvv, zww ! 3D workspace 90 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 94 INTEGER :: ji, jj, jk ! dummy loop index 95 ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) if using XIOS (subdomain support) 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace 97 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 98 ! TEMP: [tiling] This change not necessary after extra haloes development 99 LOGICAL :: lskip 91 100 !!---------------------------------------------------------------------- 92 101 ! 93 102 IF( ln_timing ) CALL timing_start('tra_adv') 94 103 ! 95 ! !== effective transport ==! 96 zuu(:,:,jpk) = 0._wp 97 zvv(:,:,jpk) = 0._wp 98 zww(:,:,jpk) = 0._wp 99 IF( ln_wave .AND. ln_sdw ) THEN 100 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift 101 zuu(:,:,jk) = & 102 & e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 103 zvv(:,:,jk) = & 104 & e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 105 zww(:,:,jk) = & 106 & e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) ) 107 END DO 108 ELSE 109 DO jk = 1, jpkm1 110 zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm) ! eulerian transport only 111 zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 112 zww(:,:,jk) = e1e2t(:,:) * ww(:,:,jk) 113 END DO 114 ENDIF 115 ! 116 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 117 zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 118 zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 119 ENDIF 120 ! 121 zuu(:,:,jpk) = 0._wp ! no transport trough the bottom 122 zvv(:,:,jpk) = 0._wp 123 zww(:,:,jpk) = 0._wp 124 ! 125 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 126 & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 127 ! 128 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) 129 ! 130 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 131 CALL iom_put( "vocetr_eff", zvv ) 132 CALL iom_put( "wocetr_eff", zww ) 133 ! 134 !!gm ??? 135 CALL dia_ptr( kt, Kmm, zvv ) ! diagnose the effective MSF 136 !!gm ??? 137 ! 138 139 IF( l_trdtra ) THEN !* Save ta and sa trends 140 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 141 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 142 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 143 ENDIF 144 ! 145 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 146 ! 147 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 148 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 149 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 150 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 151 CASE ( np_MUS ) ! MUSCL 152 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 153 CASE ( np_UBS ) ! UBS 154 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 155 CASE ( np_QCK ) ! QUICKEST 156 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 157 ! 158 END SELECT 159 ! 160 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 161 DO jk = 1, jpkm1 162 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 163 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 164 END DO 165 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 166 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 167 DEALLOCATE( ztrdt, ztrds ) 104 lskip = .FALSE. 105 106 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 107 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 108 ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 109 ENDIF 110 111 ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 112 IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia ) THEN 113 IF( ln_tile ) THEN 114 IF( ntile == 1 ) THEN 115 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 116 ELSE 117 lskip = .TRUE. 118 ENDIF 119 ENDIF 120 ENDIF 121 IF( .NOT. lskip ) THEN 122 ! !== effective transport ==! 123 IF( ln_wave .AND. ln_sdw ) THEN 124 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 125 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 126 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) 127 zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 128 END_3D 129 ELSE 130 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 131 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only 132 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) 133 zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) 134 END_3D 135 ENDIF 136 ! 137 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 138 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 139 zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 140 zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) 141 END_3D 142 ENDIF 143 ! 144 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 145 zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom 146 zvv(ji,jj,jpk) = 0._wp 147 zww(ji,jj,jpk) = 0._wp 148 END_2D 149 ! 150 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 151 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 152 & CALL ldf_eiv_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 153 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 154 ! 155 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 156 & 'TRA', Kmm ) ! add the mle transport (if necessary) 157 ! 158 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 159 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 160 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 161 CALL iom_put( "vocetr_eff", zvv ) 162 CALL iom_put( "wocetr_eff", zww ) 163 ENDIF 164 ! 165 !!gm ??? 166 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 167 CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF 168 !!gm ??? 169 ! 170 171 IF( l_trdtra ) THEN !* Save ta and sa trends 172 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 173 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 174 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 175 ENDIF 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 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 179 ! 180 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 181 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kmm), 'T', 1. ) 182 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 183 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 184 IF (nn_hls.EQ.2) THEN 185 CALL lbc_lnk_multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 186 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 187 #if defined key_loop_fusion 188 CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 189 #else 190 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 191 #endif 192 ELSE 193 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 194 END IF 195 CASE ( np_MUS ) ! MUSCL 196 ! NOTE: [tiling-comms-merge] I added this lbc_lnk as it did not validate against the trunk when using ln_zco 197 IF (nn_hls.EQ.2) THEN 198 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 199 #if defined key_loop_fusion 200 CALL tra_adv_mus_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 201 #else 202 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 203 #endif 204 ELSE 205 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 206 END IF 207 CASE ( np_UBS ) ! UBS 208 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 209 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 210 CASE ( np_QCK ) ! QUICKEST 211 IF (nn_hls.EQ.2) THEN 212 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 213 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 214 END IF 215 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 216 ! 217 END SELECT 218 ! 219 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 220 DO jk = 1, jpkm1 221 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 222 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 223 END DO 224 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 225 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 226 DEALLOCATE( ztrdt, ztrds ) 227 ENDIF 228 229 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 230 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 231 168 232 ENDIF 169 233 ! ! print mean trends (used for debugging) 170 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, 234 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & 171 235 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 236 237 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 238 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 239 DEALLOCATE( zuu, zvv, zww ) 240 ENDIF 172 241 ! 173 242 IF( ln_timing ) CALL timing_stop( 'tra_adv' ) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv_cen.F90
r13497 r13984 71 71 INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) 72 72 INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) 73 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 73 74 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 74 75 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 78 79 REAL(wp) :: zC2t_u, zC4t_u ! local scalars 79 80 REAL(wp) :: zC2t_v, zC4t_v ! - - 80 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zwy, zwz, ztu, ztv, ztw81 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw 81 82 !!---------------------------------------------------------------------- 82 83 ! 83 IF( kt == kit000 ) THEN 84 IF(lwp) WRITE(numout,*) 85 IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 86 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 84 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 85 IF( kt == kit000 ) THEN 86 IF(lwp) WRITE(numout,*) 87 IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 88 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 89 ENDIF 90 ! ! set local switches 91 l_trd = .FALSE. 92 l_hst = .FALSE. 93 l_ptr = .FALSE. 94 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 95 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 96 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 97 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 87 98 ENDIF 88 ! ! set local switches89 l_trd = .FALSE.90 l_hst = .FALSE.91 l_ptr = .FALSE.92 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.93 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.94 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &95 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.96 99 ! 97 100 ! … … 112 115 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 113 116 ztv(:,:,jpk) = 0._wp 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! masked gradient117 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! masked gradient 115 118 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 116 119 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 117 120 END_3D 118 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond.121 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 119 122 ! 120 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes123 DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes 121 124 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) 122 125 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 128 131 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v 129 132 END_3D 130 CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. )133 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 131 134 ! 132 135 CASE DEFAULT … … 155 158 END_2D 156 159 ELSE ! no ice-shelf cavities (only ocean surface) 157 zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 160 DO_2D( 1, 1, 1, 1 ) 161 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 162 END_2D 158 163 ENDIF 159 164 ENDIF … … 171 176 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 172 177 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 173 END 174 ! ! "Poleward" heat and salt transports 178 ENDIF 179 ! ! "Poleward" heat and salt transports 175 180 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 176 181 ! ! heat and salt transport -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv_fct.F90
r13497 r13984 34 34 PUBLIC tra_adv_fct ! called by traadv.F90 35 35 PUBLIC interp_4th_cpt ! called by traadv_cen.F90 36 PUBLIC tridia_solver ! called by traadv_fct_lf.F90 37 PUBLIC nonosc ! called by traadv_fct_lf.F90 - key_agrif 36 38 37 39 LOGICAL :: l_trd ! flag to compute trends … … 79 81 INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) 80 82 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 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 reverted 81 85 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 82 86 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation 83 87 ! 84 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 INTEGER :: ji, jj, jk, jn ! dummy loop indices 85 89 REAL(wp) :: ztra ! local scalar 86 90 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - 87 91 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - 88 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw92 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 89 93 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 90 94 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup … … 92 96 !!---------------------------------------------------------------------- 93 97 ! 94 IF( kt == kit000 ) THEN 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 98 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 99 IF( kt == kit000 ) THEN 100 IF(lwp) WRITE(numout,*) 101 IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 102 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 103 ENDIF 104 ! NOTE: [tiling-comms-merge] Bug fix- move array zeroing out of this IF block 105 ! 106 l_trd = .FALSE. ! set local switches 107 l_hst = .FALSE. 108 l_ptr = .FALSE. 109 ll_zAimp = .FALSE. 110 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 111 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 112 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 113 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 114 ! 98 115 ENDIF 116 99 117 !! -- init to 0 100 118 zwi(:,:,:) = 0._wp … … 108 126 ztw(:,:,:) = 0._wp 109 127 ! 110 l_trd = .FALSE. ! set local switches111 l_hst = .FALSE.112 l_ptr = .FALSE.113 ll_zAimp = .FALSE.114 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.115 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.116 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &117 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.118 !119 128 IF( l_trd .OR. l_hst ) THEN 120 ALLOCATE( ztrdx( jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) )129 ALLOCATE( ztrdx(A2D(nn_hls),jpk), ztrdy(A2D(nn_hls),jpk), ztrdz(A2D(nn_hls),jpk) ) 121 130 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 122 131 ENDIF 123 132 ! 124 IF( l_ptr ) THEN 125 ALLOCATE( zptry( jpi,jpj,jpk) )133 IF( l_ptr ) THEN 134 ALLOCATE( zptry(A2D(nn_hls),jpk) ) 126 135 zptry(:,:,:) = 0._wp 127 136 ENDIF 128 ! ! surface & bottom value : flux set to zero one for all129 zwz(:,:, 1 ) = 0._wp130 zwx(:,:,jpk) = 0._wp ; zwy(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp131 !132 zwi(:,:,:) = 0._wp133 137 ! 134 138 ! If adaptive vertical advection, check if it is needed on this PE at this time 135 139 IF( ln_zad_Aimp ) THEN 136 IF( MAXVAL( ABS( wi( :,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE.140 IF( MAXVAL( ABS( wi(A2D(nn_hls),:) ) ) > 0._wp ) ll_zAimp = .TRUE. 137 141 END IF 138 142 ! If active adaptive vertical advection, build tridiagonal matrix 139 143 IF( ll_zAimp ) THEN 140 ALLOCATE(zwdia( jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk))141 DO_3D( 0, 0, 0, 0, 1, jpkm1 )144 ALLOCATE(zwdia(A2D(nn_hls),jpk), zwinf(A2D(nn_hls),jpk), zwsup(A2D(nn_hls),jpk)) 145 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) 142 146 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & 143 147 & / e3t(ji,jj,jk,Krhs) … … 151 155 ! !== upstream advection with initial mass fluxes & intermediate update ==! 152 156 ! !* upstream tracer flux in the i and j direction 153 DO_3D( 1, 0, 1, 0, 1, jpkm1 )157 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 154 158 ! upstream scheme 155 159 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) … … 178 182 ENDIF 179 183 ! 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme184 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme 181 185 ! ! total intermediate advective trends 182 186 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & … … 194 198 ! 195 199 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask)200 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 197 201 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 198 202 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 206 210 ! 207 211 END IF 208 ! 212 ! 209 213 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 210 214 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) … … 218 222 ! 219 223 CASE( 2 ) !- 2nd order centered 220 DO_3D( 1, 0, 1, 0, 1, jpkm1 )224 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 221 225 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) 222 226 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) … … 238 242 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 239 243 ! 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes244 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 241 245 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points 242 246 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 243 ! ! C4 minus upstream advective fluxes 247 ! ! C4 minus upstream advective fluxes 244 248 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 245 249 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 246 250 END_3D 251 IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 247 252 ! 248 253 CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested 249 254 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 250 255 ztv(:,:,jpk) = 0._wp 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (gradient)256 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! 1st derivative (gradient) 252 257 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 253 258 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 254 259 END_3D 255 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 260 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 261 ! 262 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 256 263 ! 257 264 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes … … 265 272 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 266 273 END_3D 274 IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 267 275 ! 268 276 END SELECT … … 271 279 ! 272 280 CASE( 2 ) !- 2nd order centered 273 DO_3D( 0, 0, 0, 0, 2, jpkm1 )281 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 274 282 zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & 275 283 & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) … … 278 286 CASE( 4 ) !- 4th order COMPACT 279 287 CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point 280 DO_3D( 0, 0, 0, 0, 2, jpkm1 )288 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 281 289 zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 282 290 END_3D … … 286 294 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 287 295 ENDIF 288 ! 296 ! 297 IF (nn_hls.EQ.1) THEN 298 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 299 ELSE 300 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 301 END IF 302 ! 303 IF (nn_hls.EQ.1) THEN 304 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 305 ELSE 306 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 307 END IF 308 ! 289 309 IF ( ll_zAimp ) THEN 290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme310 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme 291 311 ! ! total intermediate advective trends 292 312 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 293 313 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 294 314 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 295 ztw(ji,jj,jk) 315 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 296 316 END_3D 297 317 ! 298 318 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 299 319 ! 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask)320 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 301 321 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 302 322 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 303 zwz(ji,jj,jk) = 323 zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 304 324 END_3D 305 325 END IF 306 !307 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'W', 1.0_wp )308 326 ! 309 327 ! !== monotonicity algorithm ==! … … 334 352 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 335 353 END_3D 336 END IF 337 ! 354 END IF 355 ! NOTE: [tiling-comms-merge] I tested this 356 ! NOT TESTED - NEED l_trd OR l_hst TRUE 338 357 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 339 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 358 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 340 359 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 341 360 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! … … 350 369 ! 351 370 ENDIF 371 ! NOTE: [tiling-comms-merge] I tested this 372 ! NOT TESTED - NEED l_ptr TRUE 352 373 IF( l_ptr ) THEN ! "Poleward" transports 353 374 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes … … 360 381 DEALLOCATE( zwdia, zwinf, zwsup ) 361 382 ENDIF 362 IF( l_trd .OR. l_hst ) THEN 383 IF( l_trd .OR. l_hst ) THEN 363 384 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 364 385 ENDIF … … 383 404 !! in-space based differencing for fluid 384 405 !!---------------------------------------------------------------------- 385 INTEGER , INTENT(in ) :: Kmm ! time level index 386 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 387 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field 388 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 406 INTEGER , INTENT(in ) :: Kmm ! time level index 407 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 408 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field 409 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field 410 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 389 411 ! 390 412 INTEGER :: ji, jj, jk ! dummy loop indices … … 392 414 REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 393 415 REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 394 REAL(dp), DIMENSION( jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo416 REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo 395 417 !!---------------------------------------------------------------------- 396 418 ! … … 402 424 ! -------------------- 403 425 ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 404 zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & 405 & paft * tmask - zbig * ( 1._wp - tmask ) ) 406 zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & 407 & paft * tmask + zbig * ( 1._wp - tmask ) ) 426 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 427 zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & 428 & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) 429 zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & 430 & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) 431 END_3D 408 432 409 433 DO jk = 1, jpkm1 410 434 ikm1 = MAX(jk-1,1) 411 DO_2D( 0, 0, 0, 0)435 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 412 436 413 437 ! search maximum in neighbourhood … … 439 463 END_2D 440 464 END DO 441 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign)465 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 442 466 443 467 ! 3. monotonic flux in the i & j direction (paa & pbb) 444 468 ! ---------------------------------------- 445 DO_3D( 0, 0, 0, 0, 1, jpkm1 )469 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 446 470 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 447 471 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) … … 461 485 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 462 486 END_3D 463 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign)464 487 ! 465 488 END SUBROUTINE nonosc … … 537 560 !!---------------------------------------------------------------------- 538 561 REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point 539 REAL(wp),DIMENSION( jpi,jpj,jpk), INTENT( out) :: pt_out ! field interpolated at w-point562 REAL(wp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point 540 563 ! 541 564 INTEGER :: ji, jj, jk ! dummy loop integers 542 565 INTEGER :: ikt, ikb ! local integers 543 REAL(wp),DIMENSION( jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt566 REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt 544 567 !!---------------------------------------------------------------------- 545 568 ! 546 569 ! !== build the three diagonal matrix & the RHS ==! 547 570 ! 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1)571 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) 549 572 zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal 550 573 zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal … … 565 588 END IF 566 589 ! 567 DO_2D( 0, 0, 0, 0) ! 2nd order centered at top & bottom590 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! 2nd order centered at top & bottom 568 591 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 569 592 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point … … 582 605 ! !== tridiagonal solver ==! 583 606 ! 584 DO_2D( 0, 0, 0, 0) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1607 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 585 608 zwt(ji,jj,2) = zwd(ji,jj,2) 586 609 END_2D 587 DO_3D( 0, 0, 0, 0, 3, jpkm1 )610 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 588 611 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 589 612 END_3D 590 613 ! 591 DO_2D( 0, 0, 0, 0) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1614 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 592 615 pt_out(ji,jj,2) = zwrm(ji,jj,2) 593 616 END_2D 594 DO_3D( 0, 0, 0, 0, 3, jpkm1 )617 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 595 618 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 596 619 END_3D 597 620 598 DO_2D( 0, 0, 0, 0) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk621 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 599 622 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 600 623 END_2D 601 DO_3DS( 0, 0, 0, 0, jpk-2, 2, -1 )624 DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) 602 625 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 603 626 END_3D … … 626 649 !! The 3d array zwt is used as a work space array. 627 650 !!---------------------------------------------------------------------- 628 REAL(wp),DIMENSION( :,:,:), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix629 REAL(wp),DIMENSION( :,:,:), INTENT(in ) :: pRHS ! Right-Hand-Side630 REAL(wp),DIMENSION( :,:,:), INTENT( out) :: pt_out !!gm field at level=F(klev)631 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level632 ! ! =0 pt at t-level651 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix 652 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side 653 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) 654 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level 655 ! ! =0 pt at t-level 633 656 INTEGER :: ji, jj, jk ! dummy loop integers 634 657 INTEGER :: kstart ! local indices 635 REAL(wp),DIMENSION( jpi,jpj,jpk) :: zwt ! 3D work array658 REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array 636 659 !!---------------------------------------------------------------------- 637 660 ! 638 661 kstart = 1 + klev 639 662 ! 640 DO_2D( 0, 0, 0, 0) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1663 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 641 664 zwt(ji,jj,kstart) = pD(ji,jj,kstart) 642 665 END_2D 643 DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )666 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 644 667 zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 645 668 END_3D 646 669 ! 647 DO_2D( 0, 0, 0, 0) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1670 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 648 671 pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 649 672 END_2D 650 DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )673 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 651 674 pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 652 675 END_3D 653 676 654 DO_2D( 0, 0, 0, 0) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk677 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 655 678 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 656 679 END_2D 657 DO_3DS( 0, 0, 0, 0, jpk-2, kstart, -1 )680 DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, kstart, -1 ) 658 681 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 659 682 END_3D -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv_mus.F90
r13497 r13984 81 81 LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl 82 82 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 83 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 83 84 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 84 85 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 88 89 REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars 89 90 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 90 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace91 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwy, zslpy ! - -91 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace 92 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - 92 93 !!---------------------------------------------------------------------- 93 94 ! 94 IF( kt == kit000 ) THEN 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 97 IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups 98 IF(lwp) WRITE(numout,*) '~~~~~~~' 99 IF(lwp) WRITE(numout,*) 100 ! 101 ! Upstream / MUSCL scheme indicator 102 ! 103 ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 104 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 105 ! 106 IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) 107 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 108 upsmsk(:,:) = 0._wp ! not upstream by default 109 ! 110 DO jk = 1, jpkm1 111 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 112 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 113 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area 114 END DO 115 ENDIF 116 ! 117 ENDIF 118 ! 119 l_trd = .FALSE. 120 l_hst = .FALSE. 121 l_ptr = .FALSE. 122 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 123 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 124 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 125 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 95 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 96 IF( kt == kit000 ) THEN 97 IF(lwp) WRITE(numout,*) 98 IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 99 IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups 100 IF(lwp) WRITE(numout,*) '~~~~~~~' 101 IF(lwp) WRITE(numout,*) 102 ! 103 ! Upstream / MUSCL scheme indicator 104 ! 105 ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 106 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 107 ! 108 IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) 109 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 110 upsmsk(:,:) = 0._wp ! not upstream by default 111 ! 112 DO jk = 1, jpkm1 113 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 114 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 115 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area 116 END DO 117 ENDIF 118 ! 119 ENDIF 120 ! 121 l_trd = .FALSE. 122 l_hst = .FALSE. 123 l_ptr = .FALSE. 124 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 125 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 126 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 127 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 128 ENDIF 126 129 ! 127 130 DO jn = 1, kjpt !== loop over the tracers ==! … … 132 135 zwx(:,:,jpk) = 0._wp ! bottom values 133 136 zwy(:,:,jpk) = 0._wp 134 DO_3D( 1, 0, 1, 0, 1, jpkm1 )137 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 135 138 zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 136 139 zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 137 140 END_3D 138 141 ! lateral boundary conditions (changed sign) 139 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )142 IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 140 143 ! !-- Slopes of tracer 141 144 zslpx(:,:,jpk) = 0._wp ! bottom values 142 145 zslpy(:,:,jpk) = 0._wp 143 DO_3D( 0, 1, 0, 1, 1, jpkm1 )146 DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 ) 144 147 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & 145 148 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) … … 148 151 END_3D 149 152 ! 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) !-- Slopes limitation153 DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 ) !-- Slopes limitation 151 154 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 152 155 & 2.*ABS( zwx (ji-1,jj,jk) ), & … … 157 160 END_3D 158 161 ! 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes162 DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes 160 163 ! MUSCL fluxes 161 164 z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) … … 173 176 zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 174 177 END_3D 175 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign)178 IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 176 179 ! 177 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend … … 195 198 zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions 196 199 zwx(:,:,jpk) = 0._wp 197 DO jk = 2, jpkm1! interior values198 zwx( :,:,jk) = tmask(:,:,jk) * ( pt(:,:,jk-1,jn,Kbb) - pt(:,:,jk,jn,Kbb) )199 END DO200 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior values 201 zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 202 END_3D 200 203 ! !-- Slopes of tracer 201 204 zslpx(:,:,1) = 0._wp ! surface values … … 223 226 END_2D 224 227 ELSE ! no cavities: only at the ocean surface 225 zwx(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 228 DO_2D( 1, 1, 1, 1 ) 229 zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 230 END_2D 226 231 ENDIF 227 232 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv_qck.F90
r13497 r13984 91 91 INTEGER , INTENT(in ) :: kjpt ! number of tracers 92 92 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 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 reverted 93 95 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components 94 96 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation 95 97 !!---------------------------------------------------------------------- 96 98 ! 97 IF( kt == kit000 ) THEN 98 IF(lwp) WRITE(numout,*) 99 IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 100 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 101 IF(lwp) WRITE(numout,*) 99 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 100 IF( kt == kit000 ) THEN 101 IF(lwp) WRITE(numout,*) 102 IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 103 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 104 IF(lwp) WRITE(numout,*) 105 ENDIF 106 ! 107 l_trd = .FALSE. 108 l_ptr = .FALSE. 109 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 110 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 102 111 ENDIF 103 !104 l_trd = .FALSE.105 l_ptr = .FALSE.106 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.107 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.108 !109 112 ! 110 113 ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme … … 127 130 INTEGER , INTENT(in ) :: kjpt ! number of tracers 128 131 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 132 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 129 133 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components 130 134 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation … … 132 136 INTEGER :: ji, jj, jk, jn ! dummy loop indices 133 137 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 134 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zfu, zfc, zfd138 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd 135 139 !---------------------------------------------------------------------- 136 140 ! … … 142 146 ! 143 147 !!gm why not using a SHIFT instruction... 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask148 DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask 145 149 zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer 146 150 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer 147 151 END_3D 148 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions152 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 149 153 150 154 ! 151 155 ! Horizontal advective fluxes 152 156 ! --------------------------- 153 DO_3D( 0, 0, 0, 0, 1, jpkm1 )157 DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 154 158 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 155 159 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 156 160 END_3D 157 161 ! 158 DO_3D( 0, 0, 0, 0, 1, jpkm1 )162 DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 159 163 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 160 164 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) … … 164 168 END_3D 165 169 !--- Lateral boundary conditions 166 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp )170 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) 167 171 168 172 !--- QUICKEST scheme … … 170 174 ! 171 175 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 172 DO_3D( 0, 0, 0, 0, 1, jpkm1 )176 DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) 173 177 zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 174 178 END_3D 175 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions179 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 176 180 177 181 ! 178 182 ! Tracer flux on the x-direction 179 DO jk = 1, jpkm1 180 ! 181 DO_2D( 0, 0, 0, 0 ) 182 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 183 !--- If the second ustream point is a land point 184 !--- the flux is computed by the 1st order UPWIND scheme 185 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 186 zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 187 zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 188 END_2D 189 END DO 190 ! 191 CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 183 DO_3D( 0, 0, 1, 0, 1, jpkm1 ) 184 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 185 !--- If the second ustream point is a land point 186 !--- the flux is computed by the 1st order UPWIND scheme 187 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 188 zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 189 zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 190 END_3D 192 191 ! 193 192 ! Computation of the trend … … 216 215 INTEGER , INTENT(in ) :: kjpt ! number of tracers 217 216 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 217 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 218 218 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components 219 219 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation … … 221 221 INTEGER :: ji, jj, jk, jn ! dummy loop indices 222 222 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 223 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwy, zfu, zfc, zfd ! 3D workspace223 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace 224 224 !---------------------------------------------------------------------- 225 225 ! … … 233 233 ! 234 234 !--- Computation of the ustream and downstream value of the tracer and the mask 235 DO_2D( 0, 0, 0, 0 )235 DO_2D( nn_hls-1, nn_hls-1, 0, 0 ) 236 236 ! Upstream in the x-direction for the tracer 237 237 zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) … … 240 240 END_2D 241 241 END DO 242 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 243 242 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 244 243 245 244 ! … … 247 246 ! --------------------------- 248 247 ! 249 DO_3D( 0, 0, 0, 0, 1, jpkm1 )248 DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 250 249 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 251 250 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 252 251 END_3D 253 252 ! 254 DO_3D( 0, 0, 0, 0, 1, jpkm1 )253 DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 255 254 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 256 255 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 261 260 262 261 !--- Lateral boundary conditions 263 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp )262 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 264 263 265 264 !--- QUICKEST scheme … … 267 266 ! 268 267 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 269 DO_3D( 0, 0, 0, 0, 1, jpkm1 )268 DO_3D( nn_hls-1, nn_hls-1, 0, 0, 1, jpkm1 ) 270 269 zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 271 270 END_3D 272 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) !--- Lateral boundary conditions271 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) !--- Lateral boundary conditions 273 272 ! 274 273 ! Tracer flux on the x-direction 275 DO jk = 1, jpkm1 276 ! 277 DO_2D( 0, 0, 0, 0 ) 278 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 279 !--- If the second ustream point is a land point 280 !--- the flux is computed by the 1st order UPWIND scheme 281 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 282 zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 283 zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 284 END_2D 285 END DO 286 ! 287 CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 274 DO_3D( 1, 0, 0, 0, 1, jpkm1 ) 275 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 276 !--- If the second ustream point is a land point 277 !--- the flux is computed by the 1st order UPWIND scheme 278 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 279 zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 280 zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 281 END_3D 288 282 ! 289 283 ! Computation of the trend … … 313 307 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 314 308 INTEGER , INTENT(in ) :: kjpt ! number of tracers 315 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 309 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 310 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 316 311 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation 317 312 ! 318 313 INTEGER :: ji, jj, jk, jn ! dummy loop indices 319 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwz ! 3D workspace314 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace 320 315 !!---------------------------------------------------------------------- 321 316 ! … … 332 327 IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) 333 328 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 334 DO_2D( 1, 1, 1, 1)329 DO_2D( 0, 0, 0, 0 ) 335 330 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface 336 331 END_2D 337 332 ELSE ! no ocean cavities (only ocean surface) 338 zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 333 DO_2D( 0, 0, 0, 0 ) 334 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 335 END_2D 339 336 ENDIF 340 337 ENDIF … … 359 356 !! ** Method : 360 357 !!---------------------------------------------------------------------- 361 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfu ! second upwind point362 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfd ! first douwning point363 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)364 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux358 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point 359 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point 360 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) 361 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux 365 362 !! 366 363 INTEGER :: ji, jj, jk ! dummy loop indices … … 369 366 !---------------------------------------------------------------------- 370 367 ! 371 DO_3D( 1, 1, 1, 1, 1, jpkm1 )368 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 372 369 zc = puc(ji,jj,jk) ! Courant number 373 370 zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traadv_ubs.F90
r13497 r13984 92 92 INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers 93 93 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 94 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 94 95 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components 95 96 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 99 100 REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - 100 101 REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - 101 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 102 !!---------------------------------------------------------------------- 103 ! 104 IF( kt == kit000 ) THEN 105 IF(lwp) WRITE(numout,*) 106 IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype 107 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 102 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 103 !!---------------------------------------------------------------------- 104 ! 105 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 106 IF( kt == kit000 ) THEN 107 IF(lwp) WRITE(numout,*) 108 IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype 109 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 110 ENDIF 111 ! 112 l_trd = .FALSE. 113 l_hst = .FALSE. 114 l_ptr = .FALSE. 115 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 116 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 117 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 118 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 108 119 ENDIF 109 !110 l_trd = .FALSE.111 l_hst = .FALSE.112 l_ptr = .FALSE.113 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.114 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.115 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &116 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.117 120 ! 118 121 ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers 119 122 zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp 120 123 ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp 121 !122 124 ! ! =========== 123 125 DO jn = 1, kjpt ! tracer loop … … 125 127 ! 126 128 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! 127 DO_2D( 1, 0, 1, 0) ! First derivative (masked gradient)129 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! First derivative (masked gradient) 128 130 zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 129 131 zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) … … 131 133 ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 132 134 END_2D 133 DO_2D( 0, 0, 0, 0) ! Second derivative (divergence)135 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Second derivative (divergence) 134 136 zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 135 137 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef … … 138 140 ! 139 141 END DO 140 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)142 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 141 143 ! 142 144 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) … … 153 155 END_3D 154 156 ! 155 zltu(:,:,:) = pt(:,:,:,jn,Krhs) ! store the initial trends before its update 157 DO_3D( 1, 1, 1, 1, 1, jpk ) 158 zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update 159 END_3D 156 160 ! 157 161 DO jk = 1, jpkm1 !== add the horizontal advective trend ==! … … 165 169 END DO 166 170 ! 167 zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case 168 ! ! and/or in trend diagnostic (l_trd=T) 169 ! 171 DO_3D( 1, 1, 1, 1, 1, jpk ) 172 zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case 173 END_3D ! and/or in trend diagnostic (l_trd=T) 174 ! 170 175 IF( l_trd ) THEN ! trend diagnostics 171 176 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) … … 185 190 CASE( 2 ) ! 2nd order FCT 186 191 ! 187 IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 192 IF( l_trd ) THEN 193 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 194 zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 195 END_3D 196 ENDIF 188 197 ! 189 198 ! !* upstream advection with initial mass fluxes & intermediate update ==! … … 199 208 END_2D 200 209 ELSE ! no cavities: only at the ocean surface 201 ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 210 DO_2D( 1, 1, 1, 1 ) 211 ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 212 END_2D 202 213 ENDIF 203 214 ENDIF … … 209 220 zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 210 221 END_3D 211 CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp ) ! Lateral boundary conditions on zti, zsi (unchanged sign)212 222 ! 213 223 ! !* anti-diffusive flux : high order minus low order … … 226 236 ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 227 237 END_3D 228 IF( ln_linssh ) ztw(:,:, 1 ) = pW(:,:,1) * pt(:,:,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work 238 IF( ln_linssh ) THEN 239 DO_2D( 1, 1, 1, 1 ) 240 ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work 241 END_2D 242 ENDIF 229 243 ! 230 244 END SELECT … … 262 276 !! in-space based differencing for fluid 263 277 !!---------------------------------------------------------------------- 264 INTEGER , INTENT(in ) 265 REAL(wp), INTENT(in ) 266 REAL(wp), DIMENSION 267 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: paft ! after field268 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: pcc ! monotonic flux in the k direction278 INTEGER , INTENT(in ) :: Kmm ! time level index 279 REAL(wp), INTENT(in ) :: p2dt ! tracer time-step 280 REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field 281 REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field 282 REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction 269 283 ! 270 284 INTEGER :: ji, jj, jk ! dummy loop indices 271 285 INTEGER :: ikm1 ! local integer 272 286 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 273 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zbetup, zbetdo! 3D workspace287 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace 274 288 !!---------------------------------------------------------------------- 275 289 ! … … 281 295 ! -------------------- 282 296 ! ! large negative value (-zbig) inside land 283 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 284 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 297 DO_3D( 0, 0, 0, 0, 1, jpk ) 298 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 299 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 300 END_3D 285 301 ! 286 302 DO jk = 1, jpkm1 ! search maximum in neighbourhood … … 293 309 END DO 294 310 ! ! large positive value (+zbig) inside land 295 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 296 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 311 DO_3D( 0, 0, 0, 0, 1, jpk ) 312 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 313 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 314 END_3D 297 315 ! 298 316 DO jk = 1, jpkm1 ! search minimum in neighbourhood … … 305 323 END DO 306 324 ! ! restore masked values to zero 307 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 308 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 325 DO_3D( 0, 0, 0, 0, 1, jpk ) 326 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) 327 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) 328 END_3D 309 329 ! 310 330 ! Positive and negative part of fluxes and beta terms -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traatf.F90
r13295 r13984 156 156 ENDIF 157 157 ! 158 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, & 159 & pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, & 160 & pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 161 ! 158 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp ) 159 162 160 ENDIF 163 161 ! … … 210 208 DO jn = 1, kjpt 211 209 ! 212 DO_3D( 0, 0, 0, 0, 1, jpkm1 )210 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 213 211 ztn = pt(ji,jj,jk,jn,Kmm) 214 212 ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers … … 275 273 zfact2 = zfact1 * r1_rho0 276 274 DO jn = 1, kjpt 277 DO_3D( 0, 0, 0, 0, 1, jpkm1 )275 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 278 276 ze3t_b = e3t(ji,jj,jk,Kbb) 279 277 ze3t_n = e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traatf_qco.F90
r13295 r13984 149 149 ENDIF 150 150 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., & 152 & pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., & 153 & pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 154 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1. ) 152 155 153 ENDIF 156 154 ! … … 203 201 DO jn = 1, kjpt 204 202 ! 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 )203 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 206 204 ztn = pt(ji,jj,jk,jn,Kmm) 207 205 ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers … … 268 266 zfact2 = zfact1 * r1_rho0 269 267 DO jn = 1, kjpt 270 DO_3D( 0, 0, 0, 0, 1, jpkm1 )268 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 271 269 ze3t_b = e3t(ji,jj,jk,Kbb) 272 270 ze3t_n = e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/trabbc.F90
r13295 r13984 80 80 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 81 81 ! 82 INTEGER :: ji, jj ! dummy loop indices82 INTEGER :: ji, jj, jk ! dummy loop indices 83 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace 84 84 !!---------------------------------------------------------------------- … … 86 86 IF( ln_timing ) CALL timing_start('tra_bbc') 87 87 ! 88 IF( l_trdtra ) THEN! Save the input temperature trend88 IF( l_trdtra ) THEN ! Save the input temperature trend 89 89 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 90 90 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) … … 96 96 END_2D 97 97 ! 98 CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp )99 !100 98 IF( l_trdtra ) THEN ! Send the trend for diagnostics 101 99 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) … … 104 102 ENDIF 105 103 ! 106 CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 104 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 105 CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 106 ENDIF 107 107 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 108 108 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/trabbl.F90
r13532 r13984 106 106 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 107 107 ! 108 INTEGER :: ji, jj, jk ! Dummy loop indices 108 109 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 109 110 !!---------------------------------------------------------------------- … … 112 113 ! 113 114 IF( l_trdtra ) THEN !* Save the T-S input trends 114 ALLOCATE( ztrdt(jpi,jpj,jpk) 115 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 115 116 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 116 117 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) … … 125 126 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 126 127 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 127 ! lateral boundary conditions ; just need for outputs128 CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp )129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef128 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef 130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef 131 ENDIF 131 132 ! 132 133 ENDIF … … 136 137 CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 137 138 IF(sn_cfctl%l_prtctl) & 138 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, 139 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 139 140 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 140 ! lateral boundary conditions ; just need for outputs 141 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 142 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 143 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 141 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 142 ! lateral boundary conditions ; just need for outputs 143 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 144 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 145 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 146 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 147 ENDIF 144 148 ! 145 149 ENDIF … … 187 191 INTEGER :: ik ! local integers 188 192 REAL(wp) :: zbtr ! local scalars 189 REAL(wp), DIMENSION( jpi,jpj) :: zptb ! workspace193 REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace 190 194 !!---------------------------------------------------------------------- 191 195 ! … … 235 239 INTEGER :: iis , iid , ijs , ijd ! local integers 236 240 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 241 INTEGER :: isi, isj ! - - 237 242 REAL(wp) :: zbtr, ztra ! local scalars 238 243 REAL(wp) :: zu_bbl, zv_bbl ! - - 239 244 !!---------------------------------------------------------------------- 240 245 ! 246 IF( ntsi == Nis0 ) THEN ; isi = 1 ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 247 IF( ntsj == Njs0 ) THEN ; isj = 1 ; ELSE ; isj = 0 ; ENDIF 241 248 ! ! =========== 242 249 DO jn = 1, kjpt ! tracer loop 243 250 ! ! =========== 244 DO jj = 1, jpjm1 245 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 246 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 247 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 248 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 249 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 250 zu_bbl = ABS( utr_bbl(ji,jj) ) 251 ! 252 ! ! up -slope T-point (shelf bottom point) 253 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 254 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 255 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 256 ! 257 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 258 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 259 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 260 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 261 END DO 262 ! 263 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 264 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 265 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 266 ENDIF 267 ! 268 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 269 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 270 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 271 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 272 zv_bbl = ABS( vtr_bbl(ji,jj) ) 273 ! 274 ! up -slope T-point (shelf bottom point) 275 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 276 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 277 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 278 ! 279 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 280 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 281 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 282 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 283 END DO 284 ! ! down-slope T-point (deep bottom point) 285 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 286 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 287 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 288 ENDIF 289 END DO 251 ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices 252 DO_2D( isj, 0, isi, 0 ) ! CAUTION start from i=1 to update i=2 when cyclic east-west 253 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 254 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 255 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 256 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 257 zu_bbl = ABS( utr_bbl(ji,jj) ) 258 ! 259 ! ! up -slope T-point (shelf bottom point) 260 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 261 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 262 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 263 ! 264 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 265 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 266 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 267 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 268 END DO 269 ! 270 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 271 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 272 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 273 ENDIF 290 274 ! 291 END DO 292 ! ! =========== 293 END DO ! end tracer 294 ! ! =========== 275 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 276 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 277 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 278 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 279 zv_bbl = ABS( vtr_bbl(ji,jj) ) 280 ! 281 ! up -slope T-point (shelf bottom point) 282 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 283 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 284 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 285 ! 286 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 287 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 288 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 289 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 290 END DO 291 ! ! down-slope T-point (deep bottom point) 292 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 293 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 294 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 295 ENDIF 296 END_2D 297 ! ! =========== 298 END DO ! end tracer 299 ! ! =========== 295 300 END SUBROUTINE tra_bbl_adv 296 301 … … 333 338 REAL(wp) :: za, zb, zgdrho ! local scalars 334 339 REAL(wp) :: zsign, zsigna, zgbbl ! - - 335 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 336 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 337 !!---------------------------------------------------------------------- 338 ! 339 IF( kt == kit000 ) THEN 340 IF(lwp) WRITE(numout,*) 341 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 342 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 340 REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace 341 REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace 342 !!---------------------------------------------------------------------- 343 ! 344 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 345 IF( kt == kit000 ) THEN 346 IF(lwp) WRITE(numout,*) 347 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 348 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 349 ENDIF 343 350 ENDIF 344 351 ! !* bottom variables (T, S, alpha, beta, depth, velocity) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/tradmp.F90
r13295 r13984 95 95 ! 96 96 INTEGER :: ji, jj, jk, jn ! dummy loop indices 97 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts) :: zts_dta97 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta 98 98 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts 99 99 !!---------------------------------------------------------------------- … … 102 102 ! 103 103 IF( l_trdtra ) THEN !* Save ta and sa trends 104 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 105 ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) 104 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 105 ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) 106 106 ENDIF 107 107 ! !== input T-S data at kt ==! … … 144 144 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 145 145 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 146 DEALLOCATE( ztrdts ) 146 DEALLOCATE( ztrdts ) 147 147 ENDIF 148 148 ! ! Control print -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traisf.F90
r13295 r13984 11 11 !!---------------------------------------------------------------------- 12 12 USE isf_oce ! Ice shelf variables 13 USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej 13 14 USE dom_oce ! ocean space domain variables 14 15 USE isfutils, ONLY : debug ! debug option … … 46 47 IF( ln_timing ) CALL timing_start('tra_isf') 47 48 ! 48 IF( kt == nit000 ) THEN 49 IF(lwp) WRITE(numout,*) 50 IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 51 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 49 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 50 IF( kt == nit000 ) THEN 51 IF(lwp) WRITE(numout,*) 52 IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 53 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 54 ENDIF 52 55 ENDIF 53 56 ! … … 76 79 ! 77 80 IF ( ln_isfdebug ) THEN 78 CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 79 CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 81 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 82 CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 83 CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 84 ENDIF 80 85 END IF 81 86 ! … … 101 106 INTEGER :: ji,jj,jk ! loop index 102 107 INTEGER :: ikt, ikb ! top and bottom level of the tbl 103 REAL(wp), DIMENSION( jpi,jpj):: ztc ! total ice shelf tracer trend108 REAL(wp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend 104 109 !!---------------------------------------------------------------------- 105 110 ! 106 111 ! compute 2d total trend due to isf 107 ztc(:,:) = 0.5_wp * ( ptsc(:,:,jp_tem) + ptsc_b(:,:,jp_tem) ) / phtbl(:,:) 112 DO_2D( 0, 0, 0, 0 ) 113 ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj) 114 END_2D 108 115 ! 109 116 ! update pts(:,:,:,:,Krhs) 110 DO_2D( 1, 1, 1, 1)117 DO_2D( 0, 0, 0, 0 ) 111 118 ! 112 119 ikt = ktop(ji,jj) … … 137 144 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc 138 145 !!---------------------------------------------------------------------- 139 INTEGER :: j k146 INTEGER :: ji, jj, jk 140 147 !!---------------------------------------------------------------------- 141 148 ! 142 DO jk = 1,jpk 143 ptsa(:,:,jk,jp_tem) = & 144 & ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 145 ptsa(:,:,jk,jp_sal) = & 146 & ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 147 END DO 149 DO_3D( 0, 0, 0, 0, 1, jpk ) 150 ptsa(ji,jj,jk,jp_tem) = ptsa(ji,jj,jk,jp_tem) + ptsc(ji,jj,jk,jp_tem) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 151 ptsa(ji,jj,jk,jp_sal) = ptsa(ji,jj,jk,jp_sal) + ptsc(ji,jj,jk,jp_sal) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 152 END_3D 148 153 ! 149 154 END SUBROUTINE tra_isf_cpl -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traldf.F90
r12377 r13984 17 17 USE oce ! ocean dynamics and tracers 18 18 USE dom_oce ! ocean space and time domain 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 20 USE domain, ONLY : dom_tile 19 21 USE phycst ! physical constants 20 22 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. … … 37 39 PUBLIC tra_ldf ! called by step.F90 38 40 PUBLIC tra_ldf_init ! called by nemogcm.F90 39 41 40 42 !!---------------------------------------------------------------------- 41 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 56 58 !! 57 59 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 60 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 61 LOGICAL :: lskip 58 62 !!---------------------------------------------------------------------- 59 63 ! 60 64 IF( ln_timing ) CALL timing_start('tra_ldf') 61 65 ! 66 lskip = .FALSE. 67 62 68 IF( l_trdtra ) THEN !* Save ta and sa trends 63 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 64 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 69 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 70 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 65 71 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 66 72 ENDIF 67 ! 68 SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend 69 CASE ( np_lap ) ! laplacian: iso-level operator 70 CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 71 CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) 72 CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 73 CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) 74 CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 75 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators 76 CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) 77 END SELECT 78 ! 79 IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics 80 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 81 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 82 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 83 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 84 DEALLOCATE( ztrdt, ztrds ) 73 74 ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 75 IF( nldf_tra == np_blp .OR. nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it ) THEN 76 IF( ln_tile ) THEN 77 IF( ntile == 1 ) THEN 78 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 79 ELSE 80 lskip = .TRUE. 81 ENDIF 82 ENDIF 83 ENDIF 84 IF( .NOT. lskip ) THEN 85 ! 86 SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend 87 CASE ( np_lap ) ! laplacian: iso-level operator 88 CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 89 CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) 90 CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 91 CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) 92 CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 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 step 95 IF(nn_hls.EQ.2) CALL lbc_lnk( 'tra_ldf', pts(:,:,:,:,Kbb), 'T',1.) 96 CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) 97 END SELECT 98 ! 99 IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics 100 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 101 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 102 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 103 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 104 DEALLOCATE( ztrdt, ztrds ) 105 ENDIF 106 107 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 108 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 85 109 ENDIF 86 110 ! !* print mean trends (used for debugging) 87 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, 111 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & 88 112 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 89 113 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traldf_iso.F90
r13497 r13984 19 19 USE oce ! ocean dynamics and active tracers 20 20 USE dom_oce ! ocean space and time domain 21 USE domutl, ONLY : is_tile 21 22 USE trc_oce ! share passive tracers/Ocean variables 22 23 USE zdf_oce ! ocean vertical physics … … 49 50 CONTAINS 50 51 51 SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & 52 & pgu , pgv , pgui, pgvi, & 53 & pt , pt2 , pt_rhs , kjpt , kpass ) 52 SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & 53 & pgu , pgv , pgui, pgvi, & 54 & pt, pt2, pt_rhs, kjpt, kpass ) 55 !! 56 INTEGER , INTENT(in ) :: kt ! ocean time-step index 57 INTEGER , INTENT(in ) :: kit000 ! first time step index 58 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 59 INTEGER , INTENT(in ) :: kjpt ! number of tracers 60 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 61 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 62 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 63 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 64 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 65 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 66 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 67 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 68 !! 69 CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 70 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 71 & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 72 END SUBROUTINE tra_ldf_iso 73 74 75 SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 76 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 77 & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 54 78 !!---------------------------------------------------------------------- 55 79 !! *** ROUTINE tra_ldf_iso *** … … 92 116 !! ** Action : Update pt_rhs arrays with the before rotated diffusion 93 117 !!---------------------------------------------------------------------- 94 INTEGER , INTENT(in ) :: kt ! ocean time-step index 95 INTEGER , INTENT(in ) :: kit000 ! first time step index 96 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 97 INTEGER , INTENT(in ) :: kjpt ! number of tracers 98 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 99 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 100 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 101 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 102 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 103 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 104 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 105 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 118 INTEGER , INTENT(in ) :: kt ! ocean time-step index 119 INTEGER , INTENT(in ) :: kit000 ! first time step index 120 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 121 INTEGER , INTENT(in ) :: kjpt ! number of tracers 122 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 123 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 124 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 125 REAL(wp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 126 REAL(wp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 127 REAL(wp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 128 REAL(wp), DIMENSION(A2D_T(ktt) ,JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 129 REAL(wp), DIMENSION(A2D_T(ktt2) ,JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 130 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 106 131 ! 107 132 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 111 136 REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - 112 137 REAL(wp) :: zcoef0, ze3w_2, zsign ! - - 113 REAL(wp), DIMENSION( jpi,jpj) :: zdkt, zdk1t, z2d114 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw138 REAL(wp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d 139 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw 115 140 !!---------------------------------------------------------------------- 116 141 ! 117 142 IF( kpass == 1 .AND. kt == kit000 ) THEN 118 IF(lwp) WRITE(numout,*) 119 IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 120 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 121 ! 122 akz (:,:,:) = 0._wp 123 ah_wslp2(:,:,:) = 0._wp 143 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 144 IF(lwp) WRITE(numout,*) 145 IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 146 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 147 ENDIF 148 ! 149 DO_3D( 0, 0, 0, 0, 1, jpk ) 150 akz (ji,jj,jk) = 0._wp 151 ah_wslp2(ji,jj,jk) = 0._wp 152 END_3D 124 153 ENDIF 125 ! 126 l_hst = .FALSE. 127 l_ptr = .FALSE. 128 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 129 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 130 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 154 ! 155 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 156 l_hst = .FALSE. 157 l_ptr = .FALSE. 158 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 159 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 160 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 161 ENDIF 131 162 ! 132 163 ! … … 167 198 ! 168 199 IF( ln_traldf_blp ) THEN ! bilaplacian operator 169 DO_3D( 1, 0, 1, 0, 2, jpkm1 )200 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 170 201 akz(ji,jj,jk) = 16._wp & 171 202 & * ah_wslp2 (ji,jj,jk) & … … 175 206 END_3D 176 207 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator 177 DO_3D( 1, 0, 1, 0, 2, jpkm1 )208 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 178 209 ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 179 210 zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) … … 183 214 ! 184 215 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 185 akz(:,:,:) = ah_wslp2(:,:,:) 216 DO_3D( 0, 0, 0, 0, 1, jpk ) 217 akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 218 END_3D 186 219 ENDIF 187 220 ENDIF … … 195 228 !!---------------------------------------------------------------------- 196 229 !!gm : bug.... why (x,:,:)? (1,jpj,:) and (jpi,1,:) should be sufficient.... 197 zdit ( 1,:,:) = 0._wp ; zdit (jpi,:,:) = 0._wp198 zdjt ( 1,:,:) = 0._wp ; zdjt (jpi,:,:) = 0._wp230 zdit (ntsi-nn_hls,:,:) = 0._wp ; zdit (ntei+nn_hls,:,:) = 0._wp 231 zdjt (ntsi-nn_hls,:,:) = 0._wp ; zdjt (ntei+nn_hls,:,:) = 0._wp 199 232 !!end 200 233 … … 223 256 DO jk = 1, jpkm1 ! Horizontal slab 224 257 ! 225 ! !== Vertical tracer gradient 226 zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * wmask(:,:,jk+1) ! level jk+1 227 ! 228 IF( jk == 1 ) THEN ; zdkt(:,:) = zdk1t(:,:) ! surface: zdkt(jk=1)=zdkt(jk=2) 229 ELSE ; zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 230 ENDIF 258 DO_2D( 1, 1, 1, 1 ) 259 ! !== Vertical tracer gradient 260 zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) ! level jk+1 261 ! 262 IF( jk == 1 ) THEN ; zdkt(ji,jj) = zdk1t(ji,jj) ! surface: zdkt(jk=1)=zdkt(jk=2) 263 ELSE ; zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk) 264 ENDIF 265 END_2D 266 ! 231 267 DO_2D( 1, 0, 1, 0 ) !== Horizontal fluxes 232 268 zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) … … 330 366 END DO ! end tracer loop 331 367 ! 332 END SUBROUTINE tra_ldf_iso 368 END SUBROUTINE tra_ldf_iso_t 333 369 334 370 !!============================================================================== -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traldf_lap_blp.F90
r13497 r13984 13 13 USE oce ! ocean dynamics and active tracers 14 14 USE dom_oce ! ocean space and time domain 15 USE domutl, ONLY : is_tile 15 16 USE ldftra ! lateral physics: eddy diffusivity 16 17 USE traldf_iso ! iso-neutral lateral diffusion (standard operator) (tra_ldf_iso routine) … … 46 47 CONTAINS 47 48 48 SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv , & 49 & pgu , pgv , pgui, pgvi, & 50 & pt , pt_rhs, kjpt, kpass ) 49 SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv, & 50 & pgu , pgv , pgui, pgvi, & 51 & pt, pt_rhs, kjpt, kpass ) 52 !! 53 INTEGER , INTENT(in ) :: kt ! ocean time-step index 54 INTEGER , INTENT(in ) :: kit000 ! first time step index 55 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 56 INTEGER , INTENT(in ) :: kjpt ! number of tracers 57 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 58 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 59 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 60 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 61 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 62 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! before tracer fields 63 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 64 !! 65 CALL tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 66 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 67 & pt, is_tile(pt), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 68 END SUBROUTINE tra_ldf_lap 69 70 71 SUBROUTINE tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 72 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 73 & pt, ktt, pt_rhs, ktt_rhs, kjpt, kpass ) 51 74 !!---------------------------------------------------------------------- 52 75 !! *** ROUTINE tra_ldf_lap *** … … 72 95 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 73 96 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 74 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 75 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 76 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before tracer fields 78 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 79 ! 80 INTEGER :: ji, jj, jk, jn ! dummy loop indices 81 REAL(wp) :: zsign ! local scalars 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zaheeu, zaheev 83 !!---------------------------------------------------------------------- 84 ! 85 IF( kt == nit000 .AND. lwp ) THEN 86 WRITE(numout,*) 87 WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 88 WRITE(numout,*) '~~~~~~~~~~~ ' 89 ENDIF 90 ! 91 l_hst = .FALSE. 92 l_ptr = .FALSE. 93 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 94 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 95 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 97 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt_rhs 98 REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 99 REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 100 REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 101 REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! before tracer fields 102 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 103 ! 104 INTEGER :: ji, jj, jk, jn ! dummy loop indices 105 INTEGER :: isi, iei, isj, iej ! local integers 106 REAL(wp) :: zsign ! local scalars 107 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zaheeu, zaheev 108 !!---------------------------------------------------------------------- 109 ! 110 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 111 IF( kt == nit000 .AND. lwp ) THEN 112 WRITE(numout,*) 113 WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 114 WRITE(numout,*) '~~~~~~~~~~~ ' 115 ENDIF 116 ! 117 l_hst = .FALSE. 118 l_ptr = .FALSE. 119 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 120 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 121 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 122 ENDIF 96 123 ! 97 124 ! !== Initialization of metric arrays used for all tracers ==! … … 99 126 ELSE ; zsign = -1._wp 100 127 ENDIF 101 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 128 129 IF( ntsi == Nis0 ) THEN ; isi = nn_hls - 1 ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 130 IF( ntsj == Njs0 ) THEN ; isj = nn_hls - 1 ; ELSE ; isj = 0 ; ENDIF 131 IF( ntei == Nie0 ) THEN ; iei = nn_hls - 1 ; ELSE ; iei = 0 ; ENDIF 132 IF( ntej == Nje0 ) THEN ; iej = nn_hls - 1 ; ELSE ; iej = 0 ; ENDIF 133 134 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) !== First derivative (gradient) ==! 102 135 zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) !!gm * umask(ji,jj,jk) pah masked! 103 136 zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) !!gm * vmask(ji,jj,jk) … … 108 141 ! ! =========== ! 109 142 ! 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== First derivative (gradient) ==!143 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) !== First derivative (gradient) ==! 111 144 ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) 112 145 ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 113 146 END_3D 114 147 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level 115 DO_2D( 1, 0, 1, 0) ! bottom148 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! bottom 116 149 ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 117 150 ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 118 151 END_2D 119 152 IF( ln_isfcav ) THEN ! top in ocean cavities only 120 DO_2D( 1, 0, 1, 0)153 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 121 154 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 122 155 IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) … … 125 158 ENDIF 126 159 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 160 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 161 DO_3D( isj, iej, isi, iei, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 128 162 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 129 163 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & … … 142 176 ! ! ================== 143 177 ! 144 END SUBROUTINE tra_ldf_lap 178 END SUBROUTINE tra_ldf_lap_t 145 179 146 180 … … 173 207 ! 174 208 INTEGER :: ji, jj, jk, jn ! dummy loop indices 175 REAL(wp), DIMENSION( jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point176 REAL(wp), DIMENSION( jpi,jpj, kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points)177 REAL(wp), DIMENSION( jpi,jpj, kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points)209 REAL(wp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point 210 REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) 211 REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) 178 212 !!--------------------------------------------------------------------- 179 213 ! 180 IF( kt == kit000 .AND. lwp ) THEN 181 WRITE(numout,*) 182 SELECT CASE ( kldf ) 183 CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype 184 CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 185 CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 186 END SELECT 187 WRITE(numout,*) '~~~~~~~~~~~' 214 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 215 IF( kt == kit000 .AND. lwp ) THEN 216 WRITE(numout,*) 217 SELECT CASE ( kldf ) 218 CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype 219 CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 220 CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 221 END SELECT 222 WRITE(numout,*) '~~~~~~~~~~~' 223 ENDIF 188 224 ENDIF 189 225 … … 200 236 END SELECT 201 237 ! 238 ! NOTE: [tiling-comms-merge] Needed for both nn_hls as tra_ldf_iso and tra_ldf_triad have not yet been adjusted to work with nn_hls = 2. In the zps case the lbc_lnk in zps_hde handles this, but in the zco case zlap always needs this lbc_lnk. I did try adjusting the bounds in tra_ldf_iso and tra_ldf_triad so this lbc_lnk was only needed for nn_hls = 1, but this was not correct and I did not have time to figure out why 202 239 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign) 203 240 ! ! Partial top/bottom cell: GRADh( zlap ) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traldf_triad.F90
r13497 r13984 13 13 USE oce ! ocean dynamics and active tracers 14 14 USE dom_oce ! ocean space and time domain 15 ! TEMP: [tiling] This change not necessary if XIOS has subdomain support 16 USE domain, ONLY : dom_tile 17 USE domutl, ONLY : is_tile 15 18 USE phycst ! physical constants 16 19 USE trc_oce ! share passive tracers/Ocean variables … … 33 36 PUBLIC tra_ldf_triad ! routine called by traldf.F90 34 37 35 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zdkt3d !: vertical tracer gradient at 2 levels36 37 38 LOGICAL :: l_ptr ! flag to compute poleward transport 38 39 LOGICAL :: l_hst ! flag to compute heat transport … … 49 50 CONTAINS 50 51 51 SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & 52 & pgu , pgv , pgui, pgvi , & 53 & pt , pt2, pt_rhs, kjpt, kpass ) 52 SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & 53 & pgu , pgv , pgui, pgvi, & 54 & pt, pt2, pt_rhs, kjpt, kpass ) 55 !! 56 INTEGER , INTENT(in ) :: kt ! ocean time-step index 57 INTEGER , INTENT(in ) :: kit000 ! first time step index 58 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 59 INTEGER , INTENT(in ) :: kjpt ! number of tracers 60 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 61 INTEGER , INTENT(in ) :: Kmm ! ocean time level indices 62 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 63 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 64 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 65 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 66 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 67 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 68 !! 69 CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 70 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 71 & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 72 END SUBROUTINE tra_ldf_triad 73 74 75 SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 76 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 77 & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 54 78 !!---------------------------------------------------------------------- 55 79 !! *** ROUTINE tra_ldf_triad *** … … 77 101 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 78 102 INTEGER , INTENT(in) :: Kmm ! ocean time level indices 79 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 80 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 81 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 82 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 83 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 84 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 103 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 104 REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 105 REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 106 REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 107 REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 108 REAL(wp), DIMENSION(A2D_T(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 109 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 85 110 ! 86 111 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 94 119 REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 95 120 REAL(wp) :: zah, zah_slp, zaei_slp 96 REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace 97 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - 121 REAL(wp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels 122 REAL(wp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace 123 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk) :: zdit, zdjt, zftu, zftv, ztfw ! 3D - 124 ! TEMP: [tiling] This can be A2D(nn_hls) if XIOS has subdomain support 125 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 98 126 !!---------------------------------------------------------------------- 99 127 ! 100 IF( .NOT.ALLOCATED(zdkt3d) ) THEN 101 ALLOCATE( zdkt3d(jpi,jpj,0:1) , STAT=ierr ) 102 CALL mpp_sum ( 'traldf_triad', ierr ) 103 IF( ierr > 0 ) CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays') 104 ENDIF 105 ! 106 IF( kpass == 1 .AND. kt == kit000 ) THEN 107 IF(lwp) WRITE(numout,*) 108 IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 109 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 110 ENDIF 111 ! 112 l_hst = .FALSE. 113 l_ptr = .FALSE. 114 IF( cdtype == 'TRA' ) THEN 115 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. 116 IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 117 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. 128 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 129 IF( kpass == 1 .AND. kt == kit000 ) THEN 130 IF(lwp) WRITE(numout,*) 131 IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 132 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 133 ENDIF 134 ! 135 l_hst = .FALSE. 136 l_ptr = .FALSE. 137 IF( cdtype == 'TRA' ) THEN 138 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. 139 IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 140 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. 141 ENDIF 118 142 ENDIF 119 143 ! … … 128 152 IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==! 129 153 ! 130 akz (:,:,:) = 0._wp 131 ah_wslp2(:,:,:) = 0._wp 132 IF( ln_ldfeiv_dia ) THEN 133 zpsi_uw(:,:,:) = 0._wp 134 zpsi_vw(:,:,:) = 0._wp 135 ENDIF 154 DO_3D( 0, 0, 0, 0, 1, jpk ) 155 akz (ji,jj,jk) = 0._wp 156 ah_wslp2(ji,jj,jk) = 0._wp 157 END_3D 136 158 ! 137 159 DO ip = 0, 1 ! i-k triads 138 160 DO kp = 0, 1 139 DO_3D( 1, 0, 1, 0, 1, jpkm1 )140 ze3wr = 1._wp / e3w(ji +ip,jj,jk+kp,Kmm)141 zbu = e1e2u(ji ,jj) * e3u(ji,jj,jk,Kmm)142 zah = 0.25_wp * pahu(ji ,jj,jk)143 zslope_skew = triadi_g(ji +ip,jj,jk,1-ip,kp)161 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 162 ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) 163 zbu = e1e2u(ji-ip,jj) * e3u(ji-ip,jj,jk,Kmm) 164 zah = 0.25_wp * pahu(ji-ip,jj,jk) 165 zslope_skew = triadi_g(ji,jj,jk,1-ip,kp) 144 166 ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 145 zslope2 = zslope_skew + ( gdept(ji +1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)167 zslope2 = zslope_skew + ( gdept(ji-ip+1,jj,jk,Kmm) - gdept(ji-ip,jj,jk,Kmm) ) * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 146 168 zslope2 = zslope2 *zslope2 147 ah_wslp2(ji +ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2148 akz (ji +ip,jj,jk+kp) = akz (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj) &149 & * r1_e1u(ji ,jj) * umask(ji,jj,jk+kp)169 ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 170 akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + zah * r1_e1u(ji-ip,jj) & 171 & * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 150 172 ! 151 IF( ln_ldfeiv_dia ) zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) &152 & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew153 173 END_3D 154 174 END DO … … 157 177 DO jp = 0, 1 ! j-k triads 158 178 DO kp = 0, 1 159 DO_3D( 1, 0, 1, 0, 1, jpkm1 )160 ze3wr = 1.0_wp / e3w(ji,jj +jp,jk+kp,Kmm)161 zbv = e1e2v(ji,jj ) * e3v(ji,jj,jk,Kmm)162 zah = 0.25_wp * pahv(ji,jj ,jk)163 zslope_skew = triadj_g(ji,jj +jp,jk,1-jp,kp)179 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 180 ze3wr = 1.0_wp / e3w(ji,jj,jk+kp,Kmm) 181 zbv = e1e2v(ji,jj-jp) * e3v(ji,jj-jp,jk,Kmm) 182 zah = 0.25_wp * pahv(ji,jj-jp,jk) 183 zslope_skew = triadj_g(ji,jj,jk,1-jp,kp) 164 184 ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 165 185 ! (do this by *adding* gradient of depth) 166 zslope2 = zslope_skew + ( gdept(ji,jj +1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)186 zslope2 = zslope_skew + ( gdept(ji,jj-jp+1,jk,Kmm) - gdept(ji,jj-jp,jk,Kmm) ) * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 167 187 zslope2 = zslope2 * zslope2 168 ah_wslp2(ji,jj +jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2169 akz (ji,jj +jp,jk+kp) = akz (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj) &170 & * r1_e2v(ji,jj ) * vmask(ji,jj,jk+kp)188 ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 189 akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + zah * r1_e2v(ji,jj-jp) & 190 & * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 171 191 ! 172 IF( ln_ldfeiv_dia ) zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) &173 & + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew174 192 END_3D 175 193 END DO … … 179 197 ! 180 198 IF( ln_traldf_blp ) THEN ! bilaplacian operator 181 DO_3D( 1, 0, 1, 0, 2, jpkm1 )199 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 182 200 akz(ji,jj,jk) = 16._wp & 183 201 & * ah_wslp2 (ji,jj,jk) & … … 187 205 END_3D 188 206 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator 189 DO_3D( 1, 0, 1, 0, 2, jpkm1 )207 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 190 208 ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 191 209 zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) … … 195 213 ! 196 214 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 197 akz(:,:,:) = ah_wslp2(:,:,:) 198 ENDIF 199 ! 200 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 215 DO_3D( 0, 0, 0, 0, 1, jpk ) 216 akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 217 END_3D 218 ENDIF 219 ! 220 ! TEMP: [tiling] These changes not necessary if XIOS has subdomain support 221 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 222 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) THEN 223 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 224 225 zpsi_uw(:,:,:) = 0._wp 226 zpsi_vw(:,:,:) = 0._wp 227 228 DO jp = 0, 1 229 DO kp = 0, 1 230 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 231 zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & 232 & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+jp,jj,jk,1-jp,kp) 233 zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & 234 & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+jp,jk,1-jp,kp) 235 END_3D 236 END DO 237 END DO 238 CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 239 240 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) 241 ENDIF 242 ENDIF 201 243 ! 202 244 ENDIF !== end 1st pass only ==! … … 234 276 DO jk = 1, jpkm1 235 277 ! !== Vertical tracer gradient at level jk and jk+1 236 zdkt3d(:,:,1) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 278 DO_2D( 1, 1, 1, 1 ) 279 zdkt3d(ji,jj,1) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 280 END_2D 237 281 ! 238 282 ! ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) 239 283 IF( jk == 1 ) THEN ; zdkt3d(:,:,0) = zdkt3d(:,:,1) 240 ELSE ; zdkt3d(:,:,0) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 284 ELSE 285 DO_2D( 1, 1, 1, 1 ) 286 zdkt3d(ji,jj,0) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 287 END_2D 241 288 ENDIF 242 289 ! … … 380 427 END DO ! end tracer loop 381 428 ! ! =============== 382 END SUBROUTINE tra_ldf_triad 429 END SUBROUTINE tra_ldf_triad_t 383 430 384 431 !!============================================================================== -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/tramle.F90
r13497 r13984 79 79 !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 80 80 !!---------------------------------------------------------------------- 81 INTEGER 82 INTEGER 83 INTEGER 84 CHARACTER(len=3) 85 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components86 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components87 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport81 INTEGER , INTENT(in ) :: kt ! ocean time-step index 82 INTEGER , INTENT(in ) :: kit000 ! first time step index 83 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 84 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 85 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components 86 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pv ! out: same 3 transport components 87 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the MLE induced transport 88 88 ! 89 89 INTEGER :: ji, jj, jk ! dummy loop indices … … 91 91 REAL(wp) :: zcuw, zmuw, zc ! local scalar 92 92 REAL(wp) :: zcvw, zmvw ! - - 93 INTEGER , DIMENSION(jpi,jpj) :: inml_mle 94 REAL(wp), DIMENSION(jpi,jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 95 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 93 INTEGER , DIMENSION(A2D(nn_hls)) :: inml_mle 94 REAL(wp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_MH 95 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 96 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 97 REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: zLf_NH 98 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zpsiu_mle, zpsiv_mle 96 99 !!---------------------------------------------------------------------- 97 100 ! 98 101 ! !== MLD used for MLE ==! 99 102 ! ! compute from the 10m density to deal with the diurnal cycle 100 inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1) 103 DO_2D( 1, 1, 1, 1 ) 104 inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) 105 END_2D 101 106 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 102 107 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) … … 135 140 END SELECT 136 141 ! ! convert density into buoyancy 137 zbm(:,:) = + grav * zbm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 142 DO_2D( 1, 1, 1, 1 ) 143 zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 144 END_2D 138 145 ! 139 146 ! … … 206 213 END DO 207 214 215 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 208 216 IF( cdtype == 'TRA') THEN !== outputs ==! 209 ! 210 zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:) ! Lf = N H / f 211 CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f 217 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 218 ALLOCATE( zLf_NH(jpi,jpj), zpsiu_mle(jpi,jpj,jpk), zpsiv_mle(jpi,jpj,jpk) ) 219 zpsiu_mle(:,:,:) = 0._wp ; zpsiv_mle(:,:,:) = 0._wp 220 ENDIF 221 ! 222 DO_2D( 0, 0, 0, 0 ) 223 zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f 224 END_2D 212 225 ! 213 226 ! divide by cross distance to give streamfunction with dimensions m^2/s 214 DO jk = 1, ikmax+1 215 zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) 216 zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) 217 END DO 218 CALL iom_put( "psiu_mle", zpsi_uw ) ! i-mle streamfunction 219 CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction 227 DO_3D( 0, 0, 0, 0, 1, ikmax+1 ) 228 zpsiu_mle(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) 229 zpsiv_mle(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) 230 END_3D 231 232 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 233 CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f 234 CALL iom_put( "psiu_mle", zpsiu_mle ) ! i-mle streamfunction 235 CALL iom_put( "psiv_mle", zpsiv_mle ) ! j-mle streamfunction 236 DEALLOCATE( zLf_NH, zpsiu_mle, zpsiv_mle ) 237 ENDIF 220 238 ENDIF 221 239 ! … … 283 301 IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 284 302 z1_t2 = 1._wp / ( rn_time * rn_time ) 285 DO_2D( 0, 1, 0, 1) ! "coriolis+ time^-1" at u- & v-points303 DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) ! "coriolis+ time^-1" at u- & v-points 286 304 zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 287 305 zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp … … 289 307 rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) 290 308 END_2D 291 CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp )309 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 292 310 ! 293 311 ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/tranpc.F90
r13497 r13984 17 17 USE oce ! ocean dynamics and active tracers 18 18 USE dom_oce ! ocean space and time domain 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed) 20 USE domain, ONLY : dom_tile 19 21 USE phycst ! physical constants 20 22 USE zdf_oce ! ocean vertical physics … … 32 34 33 35 PUBLIC tra_npc ! routine called by step.F90 36 37 INTEGER :: nnpcc ! number of statically instable water column 34 38 35 39 !! * Substitutions … … 64 68 ! 65 69 INTEGER :: ji, jj, jk ! dummy loop indices 66 INTEGER :: inpcc ! number of statically instable water column67 70 INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers 68 71 LOGICAL :: l_bottom_reached, l_column_treated … … 70 73 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt 71 74 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 72 REAL(wp), DIMENSION( jpk ) :: zvn2! vertical profile of N2 at 1 given point...73 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab! vertical profile of T & S , and alpha & betaat 1 given point74 REAL(wp), DIMENSION( jpi,jpj,jpk ) :: zn2 ! N^275 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts) :: zab! alpha and beta75 REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... 76 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point 77 REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2 78 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta 76 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 77 80 ! 78 81 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 79 82 INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" 83 INTEGER :: isi, isj, iei, iej 80 84 LOGICAL :: lp_monitor_point = .FALSE. ! in CPU domain "nncpu" 81 85 !!---------------------------------------------------------------------- … … 87 91 IF( l_trdtra ) THEN !* Save initial after fields 88 92 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 89 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 93 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 90 94 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 91 95 ENDIF … … 101 105 CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm ) ! after Brunt-Vaisala (given on W-points) 102 106 ! 103 inpcc = 0 104 ! 105 DO_2D( 0, 0, 0, 0 ) ! interior column only 107 IF( ntile == 0 .OR. ntile == 1 ) nnpcc = 0 ! Do only on the first tile 108 ! 109 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 110 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 111 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 112 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 113 ! 114 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 115 DO_2D( isj, iej, isi, iei ) ! interior column only 106 116 ! 107 117 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points … … 160 170 ENDIF 161 171 ! 162 IF( jiter == 1 ) inpcc = inpcc + 1172 IF( jiter == 1 ) nnpcc = nnpcc + 1 163 173 ! 164 174 IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer … … 310 320 ENDIF 311 321 ! 312 CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )313 !314 IF( lwp .AND. l_LB_debug ) THEN315 WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc316 WRITE(numout,*)322 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 323 IF( lwp .AND. l_LB_debug ) THEN 324 WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', nnpcc 325 WRITE(numout,*) 326 ENDIF 317 327 ENDIF 318 328 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/traqsr.F90
r13497 r13984 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE sbc_oce ! surface boundary condition: ocean 25 26 USE trc_oce ! share SMS/Ocean variables … … 107 108 ! 108 109 INTEGER :: ji, jj, jk ! dummy loop indices 109 INTEGER :: irgb 110 INTEGER :: irgb, isi, iei, isj, iej ! local integers 110 111 REAL(wp) :: zchl, zcoef, z1_2 ! local scalars 111 112 REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - … … 120 121 IF( ln_timing ) CALL timing_start('tra_qsr') 121 122 ! 122 IF( kt == nit000 ) THEN 123 IF(lwp) WRITE(numout,*) 124 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 125 IF(lwp) WRITE(numout,*) '~~~~~~~' 123 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 124 IF( kt == nit000 ) THEN 125 IF(lwp) WRITE(numout,*) 126 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 127 IF(lwp) WRITE(numout,*) '~~~~~~~' 128 ENDIF 126 129 ENDIF 127 130 ! 128 131 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 132 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 133 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 131 134 ENDIF … … 134 137 ! ! before qsr induced heat content ! 135 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_atf 140 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 141 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 142 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 143 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 144 136 145 IF( kt == nit000 ) THEN !== 1st time step ==! 137 146 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 .AND. .NOT.l_1st_euler ) THEN ! read in restart 138 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'139 147 z1_2 = 0.5_wp 140 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 149 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' 150 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 151 ENDIF 141 152 ELSE ! No restart or restart not found: Euler forward time stepping 142 153 z1_2 = 1._wp 143 qsr_hc_b(:,:,:) = 0._wp 154 DO_3D( isj, iej, isi, iei, 1, jpk ) 155 qsr_hc_b(ji,jj,jk) = 0._wp 156 END_3D 144 157 ENDIF 145 158 ELSE !== Swap of qsr heat content ==! 146 159 z1_2 = 0.5_wp 147 qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 160 DO_3D( isj, iej, isi, iei, 1, jpk ) 161 qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) 162 END_3D 148 163 ENDIF 149 164 ! … … 154 169 CASE( np_BIO ) !== bio-model fluxes ==! 155 170 ! 156 DO jk = 1, nksr157 qsr_hc( :,:,jk) = r1_rho0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) )158 END DO171 DO_3D( isj, iej, isi, iei, 1, nksr ) 172 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) 173 END_3D 159 174 ! 160 175 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 161 176 ! 162 ALLOCATE( ze0 ( jpi,jpj) , ze1 (jpi,jpj) , &163 & ze2 ( jpi,jpj) , ze3 (jpi,jpj) , &164 & ztmp3d( jpi,jpj,nksr + 1) )177 ALLOCATE( ze0 (A2D(nn_hls)) , ze1 (A2D(nn_hls)) , & 178 & ze2 (A2D(nn_hls)) , ze3 (A2D(nn_hls)) , & 179 & ztmp3d(A2D(nn_hls),nksr + 1) ) 165 180 ! 166 181 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll 167 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 182 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 183 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 184 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 185 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) ! Revert to tile domain 186 ENDIF 168 187 ! 169 188 ! Separation in R-G-B depending on the surface Chl … … 172 191 ! most expensive calculations) 173 192 ! 174 DO_2D( 0, 0, 0, 0)193 DO_2D( isj, iej, isi, iei ) 175 194 ! zlogc = log(zchl) 176 195 zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) ) … … 191 210 192 211 ! 193 DO_3D( 0, 0, 0, 0, 1, nksr + 1 )212 DO_3D( isj, iej, isi, iei, 1, nksr + 1 ) 194 213 ! zchl = ALOG( ze0(ji,jj) ) 195 214 zlogc = ze0(ji,jj) … … 216 235 zlui = 41 + 20.*LOG10(zchl) + 1.e-15 217 236 DO jk = 1, nksr + 1 218 ztmp3d(:,:,jk) = zlui 237 ztmp3d(:,:,jk) = zlui 219 238 END DO 220 239 ENDIF 221 240 ! 222 241 zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B 223 DO_2D( 0, 0, 0, 0)242 DO_2D( isj, iej, isi, iei ) 224 243 ze0(ji,jj) = rn_abs * qsr(ji,jj) 225 244 ze1(ji,jj) = zcoef * qsr(ji,jj) … … 232 251 ! 233 252 ! !* interior equi-partition in R-G-B depending on vertical profile of Chl 234 DO_3D( 0, 0, 0, 0, 2, nksr + 1 )253 DO_3D( isj, iej, isi, iei, 2, nksr + 1 ) 235 254 ze3t = e3t(ji,jj,jk-1,Kmm) 236 255 irgb = NINT( ztmp3d(ji,jj,jk) ) … … 246 265 END_3D 247 266 ! 248 DO_3D( 0, 0, 0, 0, 1, nksr ) !* now qsr induced heat content267 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 249 268 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 250 269 END_3D … … 256 275 zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands 257 276 zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 258 DO_3D( 0, 0, 0, 0, 1, nksr ) ! solar heat absorbed at T-point in the top 400m277 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 259 278 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 260 279 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) … … 274 293 ! 275 294 ! sea-ice: store the 1st ocean level attenuation coefficient 276 DO_2D( 0, 0, 0, 0)295 DO_2D( isj, iej, isi, iei ) 277 296 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) 278 297 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 279 298 ENDIF 280 299 END_2D 281 CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 282 ! 283 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 284 ALLOCATE( zetot(jpi,jpj,jpk) ) 285 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 286 DO jk = nksr, 1, -1 287 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 288 END DO 289 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 290 DEALLOCATE( zetot ) 291 ENDIF 292 ! 293 IF( lrst_oce ) THEN ! write in the ocean restart file 294 IF( lwxios ) CALL iom_swap( cwxios_context ) 295 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios ) 296 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 297 IF( lwxios ) CALL iom_swap( cxios_context ) 300 ! 301 ! TEMP: [tiling] This change not necessary and working array can use A2D(nn_hls) if using XIOS (subdomain support) 302 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 303 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 304 ALLOCATE( zetot(jpi,jpj,jpk) ) 305 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 306 DO jk = nksr, 1, -1 307 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 308 END DO 309 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 310 DEALLOCATE( zetot ) 311 ENDIF 312 ENDIF 313 ! 314 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 315 IF( lrst_oce ) THEN ! write in the ocean restart file 316 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) 317 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) 318 ENDIF 298 319 ENDIF 299 320 ! … … 301 322 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 302 323 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 303 DEALLOCATE( ztrdt ) 324 DEALLOCATE( ztrdt ) 304 325 ENDIF 305 326 ! ! print mean trends (used for debugging) … … 431 452 ! 1st ocean level attenuation coefficient (used in sbcssm) 432 453 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 433 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev , ldxios = lrxios)454 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev ) 434 455 ELSE 435 456 fraqsr_1lev(:,:) = 1._wp ! default : no penetration 436 457 ENDIF 437 458 ! 438 IF( lwxios ) THEN439 CALL iom_set_rstw_var_active('qsr_hc_b')440 CALL iom_set_rstw_var_active('fraqsr_1lev')441 ENDIF442 !443 459 END SUBROUTINE tra_qsr_init 444 460 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/trasbc.F90
r13497 r13984 76 76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 77 77 ! 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices79 INTEGER :: ikt, ikb 80 REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar78 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 INTEGER :: ikt, ikb, isi, iei, isj, iej ! local integers 80 REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar 81 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 82 82 !!---------------------------------------------------------------------- … … 84 84 IF( ln_timing ) CALL timing_start('tra_sbc') 85 85 ! 86 IF( kt == nit000 ) THEN 87 IF(lwp) WRITE(numout,*) 88 IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 89 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 86 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 87 IF( kt == nit000 ) THEN 88 IF(lwp) WRITE(numout,*) 89 IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 90 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 91 ENDIF 90 92 ENDIF 91 93 ! 92 94 IF( l_trdtra ) THEN !* Save ta and sa trends 93 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )95 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 94 96 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 95 97 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 96 98 ENDIF 97 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_atf 101 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 102 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 103 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 104 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 105 98 106 !!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 99 107 IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration 100 qns(:,:) = qns(:,:) + qsr(:,:) ! total heat flux in qns 101 qsr(:,:) = 0._wp ! qsr set to zero 108 DO_2D( isj, iej, isi, iei ) 109 qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns 110 qsr(ji,jj) = 0._wp ! qsr set to zero 111 END_2D 102 112 ENDIF 103 113 … … 109 119 IF( ln_rstart .AND. & ! Restart: read in restart file 110 120 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 111 IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file'112 121 zfact = 0.5_wp 113 sbc_tsc(:,:,:) = 0._wp 114 CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend 115 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend 122 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 123 IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' 124 sbc_tsc(:,:,:) = 0._wp 125 CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend 126 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 127 ENDIF 116 128 ELSE ! No restart or restart not found: Euler forward time stepping 117 129 zfact = 1._wp 118 sbc_tsc(:,:,:) = 0._wp 119 sbc_tsc_b(:,:,:) = 0._wp 130 DO_2D( isj, iej, isi, iei ) 131 sbc_tsc(ji,jj,:) = 0._wp 132 sbc_tsc_b(ji,jj,:) = 0._wp 133 END_2D 120 134 ENDIF 121 135 ELSE !* other time-steps: swap of forcing fields 122 136 zfact = 0.5_wp 123 sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 137 DO_2D( isj, iej, isi, iei ) 138 sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) 139 END_2D 124 140 ENDIF 125 141 ! !== Now sbc tracer content fields ==! 126 DO_2D( 0, 1, 0, 0)142 DO_2D( isj, iej, isi, iei ) 127 143 sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux 128 144 sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting 129 145 END_2D 130 146 IF( ln_linssh ) THEN !* linear free surface 131 DO_2D( 0, 1, 0, 0) !==>> add concentration/dilution effect due to constant volume cell147 DO_2D( isj, iej, isi, iei ) !==>> add concentration/dilution effect due to constant volume cell 132 148 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 133 149 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 134 150 END_2D !==>> output c./d. term 135 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 136 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 151 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 152 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 153 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 154 ENDIF 137 155 ENDIF 138 156 ! 139 157 DO jn = 1, jpts !== update tracer trend ==! 140 DO_2D( 0, 1, 0, 0 ) 158 ! NOTE: [tiling-comms-merge] This looped over nn_hls, which changes the results when using tiling 159 DO_2D( 0, 0, 0, 0 ) 141 160 pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) & 142 161 & / e3t(ji,jj,1,Kmm) … … 144 163 END DO 145 164 ! 146 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==!147 IF( l wxios ) CALL iom_swap( cwxios_context )148 CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem), ldxios = lwxios)149 CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal), ldxios = lwxios)150 IF( lwxios ) CALL iom_swap( cxios_context )165 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 166 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! 167 CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 168 CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 169 ENDIF 151 170 ENDIF 152 171 ! … … 157 176 IF( ln_rnf ) THEN ! input of heat and salt due to river runoff 158 177 zfact = 0.5_wp 159 DO_2D( 0, 1, 0, 0 )178 DO_2D( 0, 0, 0, 0 ) 160 179 IF( rnf(ji,jj) /= 0._wp ) THEN 161 180 zdep = zfact / h_rnf(ji,jj) … … 170 189 ENDIF 171 190 172 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst 173 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss 191 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 192 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst 193 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss 194 ENDIF 174 195 175 196 #if defined key_asminc … … 182 203 ! 183 204 IF( ln_linssh ) THEN 184 DO_2D( 0, 1, 0, 0 )205 DO_2D( 0, 0, 0, 0 ) 185 206 ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 186 207 pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim … … 188 209 END_2D 189 210 ELSE 190 DO_2D( 0, 1, 0, 0 )211 DO_2D( 0, 0, 0, 0 ) 191 212 ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 192 213 pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim … … 204 225 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 205 226 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 206 DEALLOCATE( ztrdt , ztrds ) 227 DEALLOCATE( ztrdt , ztrds ) 207 228 ENDIF 208 229 ! -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/trazdf.F90
r13497 r13984 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 15 USE dom_oce ! ocean space and time domain variables 16 16 USE domvvl ! variable volume 17 17 USE phycst ! physical constant … … 55 55 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 56 56 ! 57 INTEGER :: j k ! Dummy loop indices57 INTEGER :: ji, jj, jk ! Dummy loop indices 58 58 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace 59 59 !!--------------------------------------------------------------------- … … 62 62 ! 63 63 IF( kt == nit000 ) THEN 64 IF(lwp)WRITE(numout,*) 65 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 66 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 64 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 65 IF(lwp)WRITE(numout,*) 66 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 67 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 68 ENDIF 67 69 ENDIF 68 70 ! 69 71 IF( l_trdtra ) THEN !* Save ta and sa trends 70 ALLOCATE( ztrdt(jpi,jpj,jpk) 72 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 71 73 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 72 74 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) … … 80 82 ! JMM avoid negative salinities near river outlet ! Ugly fix 81 83 ! JMM : restore negative salinities to small salinities: 82 WHERE( pts( :,:,:,jp_sal,Kaa) < 0._wp ) pts(:,:,:,jp_sal,Kaa) = 0.1_wp84 WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp ) pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 83 85 !!gm 84 86 85 87 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics 86 DO jk = 1, jpk m188 DO jk = 1, jpk 87 89 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) & 88 90 & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & … … 94 96 & - ztrds(:,:,jk) 95 97 END DO 98 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 96 99 !!gm this should be moved in trdtra.F90 and done on all trends 97 100 CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) … … 140 143 INTEGER :: ji, jj, jk, jn ! dummy loop indices 141 144 REAL(wp) :: zrhs, zzwi, zzws ! local scalars 142 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwi, zwt, zwd, zws145 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws 143 146 !!--------------------------------------------------------------------- 144 147 ! … … 154 157 ! 155 158 ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 156 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ; zwt(:,:,2:jpk) = avt(:,:,2:jpk) 157 ELSE ; zwt(:,:,2:jpk) = avs(:,:,2:jpk) 159 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 160 DO_3D( 1, 1, 1, 1, 2, jpk ) 161 zwt(ji,jj,jk) = avt(ji,jj,jk) 162 END_3D 163 ELSE 164 DO_3D( 1, 1, 1, 1, 2, jpk ) 165 zwt(ji,jj,jk) = avs(ji,jj,jk) 166 END_3D 158 167 ENDIF 159 168 zwt(:,:,1) = 0._wp … … 222 231 END_2D 223 232 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 224 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & 233 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & 225 234 & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side 226 235 pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRA/zpshde.F90
r13497 r13984 17 17 USE oce ! ocean: dynamics and tracers variables 18 18 USE dom_oce ! domain: ocean variables 19 USE domutl, ONLY : is_tile 19 20 USE phycst ! physical constants 20 21 USE eosbn2 ! ocean equation of state … … 40 41 CONTAINS 41 42 42 SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & 43 & prd, pgru, pgrv ) 43 SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & 44 & prd, pgru, pgrv ) 45 !! 46 INTEGER , INTENT(in ) :: kt ! ocean time-step index 47 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 48 INTEGER , INTENT(in ) :: kjpt ! number of tracers 49 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pta ! 4D tracers fields 50 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 51 REAL(wp), DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 52 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 53 ! 54 INTEGER :: itrd, itgr 55 !! 56 IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF 57 IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF 58 59 CALL zps_hde_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), & 60 & prd, itrd, pgru, pgrv, itgr ) 61 END SUBROUTINE zps_hde 62 63 64 SUBROUTINE zps_hde_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, & 65 & prd, ktrd, pgru, pgrv, ktgr ) 44 66 !!---------------------------------------------------------------------- 45 67 !! *** ROUTINE zps_hde *** … … 85 107 !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 86 108 !!---------------------------------------------------------------------- 87 INTEGER , INTENT(in ) :: kt ! ocean time-step index 88 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 89 INTEGER , INTENT(in ) :: kjpt ! number of tracers 90 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 91 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 92 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 93 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 109 INTEGER , INTENT(in ) :: kt ! ocean time-step index 110 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 111 INTEGER , INTENT(in ) :: kjpt ! number of tracers 112 INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr 113 REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout) :: pta ! 4D tracers fields 114 REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 115 REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 116 REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 94 117 ! 95 118 INTEGER :: ji, jj, jn ! Dummy loop indices 96 119 INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points 97 120 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars 98 REAL(wp), DIMENSION( jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos99 REAL(wp), DIMENSION( jpi,jpj,kjpt) :: zti, ztj !121 REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 122 REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! 100 123 !!---------------------------------------------------------------------- 101 124 ! 102 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 IF (nn_hls.EQ.2) THEN 128 CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 129 IF(PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 130 END IF 103 131 ! 104 132 pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp … … 107 135 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 108 136 ! 109 DO_2D( 1, 0, 1, 0 )137 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level 110 138 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 111 139 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 … … 146 174 END DO 147 175 ! 148 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.176 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 149 177 ! 150 178 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) 151 179 pgru(:,:) = 0._wp 152 180 pgrv(:,:) = 0._wp ! depth of the partial step level 153 DO_2D( 1, 0, 1, 0)181 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 154 182 iku = mbku(ji,jj) 155 183 ikv = mbkv(ji,jj) … … 167 195 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 168 196 ! 169 DO_2D( 1, 0, 1, 0) ! Gradient of density at the last level197 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level 170 198 iku = mbku(ji,jj) 171 199 ikv = mbkv(ji,jj) … … 179 207 ENDIF 180 208 END_2D 181 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions209 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 182 210 ! 183 211 END IF … … 185 213 IF( ln_timing ) CALL timing_stop( 'zps_hde') 186 214 ! 187 END SUBROUTINE zps_hde 215 END SUBROUTINE zps_hde_t 188 216 189 217 190 218 SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & 191 & prd, pgru, pgrv, pgrui, pgrvi ) 219 & prd, pgru, pgrv, pgrui, pgrvi ) 220 !! 221 INTEGER , INTENT(in ) :: kt ! ocean time-step index 222 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 223 INTEGER , INTENT(in ) :: kjpt ! number of tracers 224 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pta ! 4D tracers fields 225 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 226 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 227 REAL(wp), DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 228 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 229 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 230 ! 231 INTEGER :: itrd, itgr, itgri 232 !! 233 IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF 234 IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF 235 IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF 236 237 CALL zps_hde_isf_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui), & 238 & prd, itrd, pgru, pgrv, itgr, pgrui, pgrvi, itgri ) 239 END SUBROUTINE zps_hde_isf 240 241 242 SUBROUTINE zps_hde_isf_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti, & 243 & prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri ) 192 244 !!---------------------------------------------------------------------- 193 245 !! *** ROUTINE zps_hde_isf *** … … 236 288 !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 237 289 !!---------------------------------------------------------------------- 238 INTEGER , INTENT(in ) :: kt ! ocean time-step index 239 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 240 INTEGER , INTENT(in ) :: kjpt ! number of tracers 241 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 242 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 243 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 244 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 245 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 246 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 290 INTEGER , INTENT(in ) :: kt ! ocean time-step index 291 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 292 INTEGER , INTENT(in ) :: kjpt ! number of tracers 293 INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri 294 REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout) :: pta ! 4D tracers fields 295 REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 296 REAL(wp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 297 REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 298 REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 299 REAL(wp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 247 300 ! 248 301 INTEGER :: ji, jj, jn ! Dummy loop indices 249 302 INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points 250 303 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars 251 REAL(wp), DIMENSION( jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos252 REAL(wp), DIMENSION( jpi,jpj,kjpt) :: zti, ztj !304 REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 305 REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! 253 306 !!---------------------------------------------------------------------- 254 307 ! 255 308 IF( ln_timing ) CALL timing_start( 'zps_hde_isf') 256 309 ! 310 IF (nn_hls.EQ.2) THEN 311 CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 312 IF (PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 313 END IF 314 257 315 pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp 258 316 pgtui(:,:,:) = 0._wp ; pgtvi(:,:,:) =0._wp … … 262 320 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 263 321 ! 264 DO_2D( 1, 0, 1, 0)322 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 265 323 266 324 iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points … … 302 360 END DO 303 361 ! 304 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.362 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 305 363 306 364 ! horizontal derivative of density anomalies (rd) … … 308 366 pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; 309 367 ! 310 DO_2D( 1, 0, 1, 0)368 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 311 369 312 370 iku = mbku(ji,jj) … … 329 387 CALL eos( ztj, zhj, zrj ) 330 388 331 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level389 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 332 390 iku = mbku(ji,jj) 333 391 ikv = mbkv(ji,jj) … … 344 402 END_2D 345 403 346 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions404 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 347 405 ! 348 406 END IF … … 351 409 ! 352 410 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! 353 DO_2D( 1, 0, 1, 0)411 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 354 412 iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 355 413 ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 … … 395 453 ! 396 454 END DO 397 CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.455 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 398 456 399 457 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) 400 458 ! 401 459 pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; 402 DO_2D( 1, 0, 1, 0)460 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 403 461 404 462 iku = miku(ji,jj) … … 420 478 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 421 479 ! 422 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level480 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 423 481 iku = miku(ji,jj) 424 482 ikv = mikv(ji,jj) … … 434 492 435 493 END_2D 436 CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions494 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions 437 495 ! 438 496 END IF … … 440 498 IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') 441 499 ! 442 END SUBROUTINE zps_hde_isf 500 END SUBROUTINE zps_hde_isf_t 443 501 444 502 !!====================================================================== -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/TRD/trdini.F90
r12377 r13984 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean domain 13 USE domain, ONLY : dom_tile 13 14 USE trd_oce ! trends: ocean variables 14 15 USE trdken ! trends: 3D kinetic energy … … 88 89 ! 89 90 ! IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) 90 91 92 IF( ln_tile .AND. ( l_trdtra .OR. l_trddyn ) ) THEN 93 CALL ctl_warn('Tiling is not yet implemented for the trends diagnostics; ln_tile is forced to FALSE') 94 ln_tile = .FALSE. 95 CALL dom_tile( ntsi, ntsj, ntei, ntej ) 96 ENDIF 97 91 98 !!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case 92 99 !!gm : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output... -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/USR/usrdef_nam.F90
r13286 r13984 70 70 kk_cfg = nn_GYRE 71 71 ! 72 kpi = 30 * nn_GYRE + 2 ! 72 kpi = 30 * nn_GYRE + 2 ! 73 73 kpj = 20 * nn_GYRE + 2 74 74 #if defined key_agrif -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ZDF/zdfgls.F90
r13558 r13984 1057 1057 CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) 1058 1058 ! 1059 IF( lwxios ) THEN1060 CALL iom_set_rstw_var_active('en')1061 CALL iom_set_rstw_var_active('avt_k')1062 CALL iom_set_rstw_var_active('avm_k')1063 CALL iom_set_rstw_var_active('hmxl_n')1064 ENDIF1065 !1066 1059 END SUBROUTINE zdf_gls_init 1067 1060 … … 1097 1090 ! 1098 1091 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist 1099 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios)1100 CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k , ldxios = lrxios)1101 CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k , ldxios = lrxios)1102 CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n , ldxios = lrxios)1092 CALL iom_get( numror, jpdom_auto, 'en' , en ) 1093 CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k ) 1094 CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k ) 1095 CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n ) 1103 1096 ELSE 1104 1097 IF(lwp) WRITE(numout,*) … … 1119 1112 ! ! ------------------- 1120 1113 IF(lwp) WRITE(numout,*) '---- gls-rst ----' 1121 IF( lwxios ) CALL iom_swap( cwxios_context ) 1122 CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) 1123 CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k , ldxios = lwxios ) 1124 CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k , ldxios = lwxios ) 1125 CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n, ldxios = lwxios ) 1126 IF( lwxios ) CALL iom_swap( cxios_context ) 1114 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 1115 CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k ) 1116 CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k ) 1117 CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n ) 1127 1118 ! 1128 1119 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ZDF/zdfosm.F90
r13497 r13984 1437 1437 ghamv(:,:,:) = 0. 1438 1438 ! 1439 IF( lwxios ) THEN1440 CALL iom_set_rstw_var_active('wn')1441 CALL iom_set_rstw_var_active('hbl')1442 CALL iom_set_rstw_var_active('hbli')1443 ENDIF1444 1439 END SUBROUTINE zdf_osm_init 1445 1440 … … 1474 1469 id1 = iom_varid( numror, 'wn' , ldstop = .FALSE. ) 1475 1470 IF( id1 > 0 ) THEN ! 'wn' exists; read 1476 CALL iom_get( numror, jpdom_auto, 'wn', ww , ldxios = lrxios)1471 CALL iom_get( numror, jpdom_auto, 'wn', ww ) 1477 1472 WRITE(numout,*) ' ===>>>> : ww read from restart file' 1478 1473 ELSE … … 1483 1478 id2 = iom_varid( numror, 'hbli' , ldstop = .FALSE. ) 1484 1479 IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return 1485 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios)1486 CALL iom_get( numror, jpdom_auto, 'hbli', hbli , ldxios = lrxios)1480 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl ) 1481 CALL iom_get( numror, jpdom_auto, 'hbli', hbli ) 1487 1482 WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file' 1488 1483 RETURN … … 1496 1491 !!----------------------------------------------------------------------------- 1497 1492 IF( TRIM(cdrw) == 'WRITE') THEN !* Write hbli into the restart file, then return 1493 IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN ! Do only on the last tile 1494 1498 1495 IF(lwp) WRITE(numout,*) '---- osm-rst ----' 1499 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww , ldxios = lwxios)1500 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl , ldxios = lwxios)1501 CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli , ldxios = lwxios)1496 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww ) 1497 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl ) 1498 CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli ) 1502 1499 RETURN 1503 1500 END IF … … 1550 1547 ! 1551 1548 IF( kt == nit000 ) THEN 1552 IF(lwp) WRITE(numout,*) 1553 IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 1554 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 1549 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 1550 IF(lwp) WRITE(numout,*) 1551 IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 1552 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 1553 ENDIF 1555 1554 ENDIF 1556 1555 -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ZDF/zdfric.F90
r13497 r13984 103 103 CALL ric_rst( nit000, 'READ' ) !* read or initialize all required files 104 104 ! 105 IF( lwxios ) THEN106 CALL iom_set_rstw_var_active('avt_k')107 CALL iom_set_rstw_var_active('avm_k')108 ENDIF109 105 END SUBROUTINE zdf_ric_init 110 106 … … 214 210 ! 215 211 IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it 216 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k , ldxios = lrxios)217 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k , ldxios = lrxios)212 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 213 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 218 214 ENDIF 219 215 ENDIF … … 223 219 ! ! ------------------- 224 220 IF(lwp) WRITE(numout,*) '---- ric-rst ----' 225 IF( lwxios ) CALL iom_swap( cwxios_context ) 226 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 227 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios) 228 IF( lwxios ) CALL iom_swap( cxios_context ) 221 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 222 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k) 229 223 ! 230 224 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/ZDF/zdftke.F90
r13558 r13984 721 721 CALL tke_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, dissl) 722 722 ! 723 IF( lwxios ) THEN724 CALL iom_set_rstw_var_active('en')725 CALL iom_set_rstw_var_active('avt_k')726 CALL iom_set_rstw_var_active('avm_k')727 CALL iom_set_rstw_var_active('dissl')728 ENDIF729 723 END SUBROUTINE zdf_tke_init 730 724 … … 758 752 ! 759 753 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist 760 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios)761 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k , ldxios = lrxios)762 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k , ldxios = lrxios)763 CALL iom_get( numror, jpdom_auto, 'dissl', dissl , ldxios = lrxios)754 CALL iom_get( numror, jpdom_auto, 'en' , en ) 755 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 756 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 757 CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) 764 758 ELSE ! start TKE from rest 765 759 IF(lwp) WRITE(numout,*) … … 780 774 ! ! ------------------- 781 775 IF(lwp) WRITE(numout,*) '---- tke_rst ----' 782 IF( lwxios ) CALL iom_swap( cwxios_context ) 783 CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) 784 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 785 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios ) 786 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios ) 787 IF( lwxios ) CALL iom_swap( cxios_context ) 776 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 777 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 778 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) 779 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 788 780 ! 789 781 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/do_loop_substitute.h90
r13296 r13984 59 59 #endif 60 60 61 #define DO_2D(B, T, L, R) DO jj = Njs0-(B), Nje0+(T) ; DO ji = Nis0-(L), Nie0+(R) 61 #define DO_2D(B, T, L, R) DO jj = ntsj-(B), ntej+(T) ; DO ji = ntsi-(L), ntei+(R) 62 #define A1Di(H) ntsi-H:ntei+H 63 #define A1Dj(H) ntsj-H:ntej+H 64 #define A2D(H) A1Di(H),A1Dj(H) 65 #define A1Di_T(T) (ntsi-nn_hls-1)*T+1: 66 #define A1Dj_T(T) (ntsj-nn_hls-1)*T+1: 67 #define A2D_T(T) A1Di_T(T),A1Dj_T(T) 68 #define JPK : 69 #define JPTS : 70 #define KJPT : 62 71 63 72 #define DO_3D(B, T, L, R, ks, ke) DO jk = ks, ke ; DO_2D(B, T, L, R) -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/nemogcm.F90
r13558 r13984 437 437 CALL Agrif_Declare_Var_ini ! " " " " " DOM 438 438 #endif 439 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain439 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 440 440 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 441 441 IF( sn_cfctl%l_prtctl ) & -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/par_oce.F90
r13286 r13984 65 65 INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj 66 66 67 ! Domain tiling 68 INTEGER, PUBLIC :: nijtile !: number of tiles in total 69 INTEGER, PUBLIC :: ntile !: current tile number 70 INTEGER, PUBLIC :: ntsi !: start of internal part of tile domain 71 INTEGER, PUBLIC :: ntsj ! 72 INTEGER, PUBLIC :: ntei !: end of internal part of tile domain 73 INTEGER, PUBLIC :: ntej ! 74 67 75 !!--------------------------------------------------------------------- 68 76 !! Active tracer parameters -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/step.F90
r13237 r13984 55 55 INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !! used by nemo_init 56 56 57 !! * Substitutions 58 # include "do_loop_substitute.h90" 57 59 !!---------------------------------------------------------------------- 58 60 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 85 87 !! -8- Outputs and diagnostics 86 88 !!---------------------------------------------------------------------- 87 INTEGER :: ji, jj, jk ! dummy loop indice89 INTEGER :: ji, jj, jk, jtile ! dummy loop indice 88 90 !!gm kcall can be removed, I guess 89 91 INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) … … 124 126 IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid 125 127 ENDIF 128 IF((kstp == nitrst) .AND. lwxios) THEN 129 CALL iom_swap( cw_ocerst_cxt ) 130 CALL iom_init_closedef(cw_ocerst_cxt) 131 CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) 132 #if defined key_top 133 CALL iom_swap( cw_toprst_cxt ) 134 CALL iom_init_closedef(cw_toprst_cxt) 135 CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) 136 #endif 137 ENDIF 138 #if defined key_si3 139 IF(((kstp + nn_fsbc - 1) == nitrst) .AND. lwxios) THEN 140 CALL iom_swap( cw_icerst_cxt ) 141 CALL iom_init_closedef(cw_icerst_cxt) 142 CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) 143 ENDIF 144 #endif 126 145 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) 127 146 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp … … 246 265 ! Active tracers 247 266 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 248 ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero 249 250 IF( lk_asminc .AND. ln_asmiau .AND. & 251 & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment 252 CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition 253 IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr 254 IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux 255 IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux 256 IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme 257 IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends 258 IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends 259 #if defined key_agrif 260 IF(.NOT. Agrif_Root()) & 261 & CALL Agrif_Sponge_tra ! tracers sponge 262 #endif 263 CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS 264 IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS 265 IF( lrst_oce .AND. ln_zdfosm ) & 266 & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts 267 CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing 268 269 CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields 270 IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection 271 267 ! Loop over tile domains 268 DO jtile = 1, nijtile 269 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 270 271 DO_3D( 0, 0, 0, 0, 1, jpk ) 272 ts(ji,jj,jk,:,Nrhs) = 0._wp ! set tracer trends to zero 273 END_3D 274 275 IF( lk_asminc .AND. ln_asmiau .AND. & 276 & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment 277 CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition 278 IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr 279 IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux 280 IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux 281 IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme 282 IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends 283 IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends 284 END DO 285 286 #if defined key_agrif 287 IF(.NOT. Agrif_Root()) THEN 288 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 289 CALL Agrif_Sponge_tra ! tracers sponge 290 ENDIF 291 #endif 292 293 ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) 294 DO jtile = 1, nijtile 295 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 296 297 CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS 298 IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS 299 IF( lrst_oce .AND. ln_zdfosm ) & 300 & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts 301 CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing 302 303 CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields 304 IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection 305 END DO 306 307 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Revert to tile over full domain 272 308 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 273 309 ! Set boundary conditions, time filter and swap time levels … … 338 374 IF( kstp == nit000 ) THEN ! 1st time step only 339 375 CALL iom_close( numror ) ! close input ocean restart file 376 IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) 340 377 IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce 341 378 IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) … … 353 390 IF( kstp == nitend .OR. nstop > 0 ) THEN 354 391 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 355 IF( lrxios ) CALL iom_context_finalize( crxios_context )356 392 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 357 393 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/step_oce.F90
r12377 r13984 9 9 USE oce ! ocean dynamics and tracers variables 10 10 USE dom_oce ! ocean space and time domain variables 11 USE domain, ONLY : dom_tile 11 12 USE zdf_oce ! ocean vertical physics variables 12 13 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/stpMLF.F90
r13237 r13984 364 364 IF( kstp == nitend .OR. indic < 0 ) THEN 365 365 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 366 IF(lrxios) CALL iom_context_finalize( cr xios_context )366 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 367 367 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 368 368 ENDIF -
NEMO/branches/2020/SI3_vp_rheology/src/OCE/timing.F90
r13558 r13984 109 109 110 110 s_timer%l_tdone = .FALSE. 111 s_timer%niter = s_timer%niter + 1111 IF( ntile == 0 .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1 ! All tiles count as one iteration 112 112 s_timer%t_cpu = 0. 113 113 s_timer%t_clock = 0. -
NEMO/branches/2020/SI3_vp_rheology/src/OFF/dtadyn.F90
r13497 r13984 46 46 USE fldread ! read input fields 47 47 USE timing ! Timing 48 USE trc, ONLY : ln_rsttr, numrtr, numrtw,lrst_trc48 USE trc, ONLY : ln_rsttr, lrst_trc 49 49 50 50 IMPLICIT NONE … … 795 795 !!--------------------------------------------------------------------- 796 796 INTEGER , INTENT(in ) :: kt ! time step 797 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in 797 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts ! temperature/salinity 798 798 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: puslp ! zonal isopycnal slopes 799 799 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: pvslp ! meridional isopycnal slopes -
NEMO/branches/2020/SI3_vp_rheology/src/OFF/nemogcm.F90
r13558 r13984 126 126 ENDIF 127 127 ! 128 IF((istp == nitrst) .AND. lwxios) THEN 129 CALL iom_swap( cw_toprst_cxt ) 130 CALL iom_init_closedef(cw_toprst_cxt) 131 CALL iom_setkt( istp - nit000 + 1, cw_toprst_cxt ) 132 ENDIF 133 128 134 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) 129 135 CALL iom_setkt ( istp - nit000 + 1, cxios_context ) ! say to iom that we are at time step kstp … … 340 346 CALL eos_init ! Equation of state 341 347 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 342 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain348 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 343 349 IF( sn_cfctl%l_prtctl ) & 344 350 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/SI3_vp_rheology/src/SAO/nemogcm.F90
r13286 r13984 235 235 CALL phy_cst ! Physical constants 236 236 CALL eos_init ! Equation of state 237 CALL dom_init( Nbb, Nnn, Naa , 'SAO') ! Domain237 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 238 238 239 239 -
NEMO/branches/2020/SI3_vp_rheology/src/SAS/nemogcm.F90
r13558 r13984 374 374 CALL Agrif_Declare_Var_ini ! " " " " " DOM 375 375 #endif 376 CALL dom_init( Nbb, Nnn, Naa , 'SAS') ! Domain376 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 377 377 IF( sn_cfctl%l_prtctl ) & 378 378 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/SI3_vp_rheology/src/SAS/step.F90
r12933 r13984 89 89 #endif 90 90 IF( kstp == nit000 ) CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 91 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 92 IF((kstp == nitrst) .AND. lwxios) THEN 93 CALL iom_swap( cw_ocerst_cxt ) 94 CALL iom_init_closedef(cw_ocerst_cxt) 95 CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) 96 #if defined key_top 97 CALL iom_swap( cw_toprst_cxt ) 98 CALL iom_init_closedef(cw_toprst_cxt) 99 CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) 100 #endif 101 ENDIF 91 102 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) 92 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 103 104 #if defined key_si3 105 IF(((kstp + nn_fsbc - 1) == nitrst) .AND. lwxios) THEN 106 CALL iom_swap( cw_icerst_cxt ) 107 CALL iom_init_closedef(cw_icerst_cxt) 108 CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) 109 ENDIF 110 #endif 93 111 94 112 ! ==> clem: open boundaries is mandatory for sea-ice because ice BDY is not decoupled from … … 128 146 ! File manipulation at the end of the first time step 129 147 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 130 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 148 IF( kstp == nit000 ) THEN 149 CALL iom_close( numror ) ! close input ocean restart file 150 IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) 151 ENDIF 131 152 132 153 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 140 161 CALL iom_close( numrow ) 141 162 ELSE 142 CALL iom_context_finalize( cwxios_context ) 163 CALL iom_context_finalize( cw_ocerst_cxt ) 164 iom_file(numrow)%nfid = 0 165 numrow = 0 143 166 ENDIF 144 167 lrst_oce = .FALSE. -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/domain.F90
r13458 r13984 66 66 CONTAINS 67 67 68 SUBROUTINE dom_init( Kbb, Kmm, Kaa , cdstr)68 SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 69 69 !!---------------------------------------------------------------------- 70 70 !! *** ROUTINE dom_init *** … … 82 82 !!---------------------------------------------------------------------- 83 83 INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 84 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables85 84 ! 86 85 !!st6 … … 135 134 CALL dom_nam ! read namelist ( namrun, namdom ) 136 135 ! 137 IF( lwxios ) THEN138 !define names for restart write and set core output (restart.F90)139 CALL iom_set_rst_vars(rst_wfields)140 CALL iom_set_rstw_core(cdstr)141 ENDIF142 !reset namelist for SAS143 IF(cdstr == 'SAS') THEN144 IF(lrxios) THEN145 IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS'146 lrxios = .FALSE.147 ENDIF148 ENDIF149 !150 136 CALL dom_hgr ! Horizontal mesh 151 137 -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/domvvl.F90
r13472 r13984 1105 1105 IF( ln_rstart ) THEN !* Read the restart file 1106 1106 CALL rst_read_open ! open the restart file if necessary 1107 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)1107 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 1108 1108 ! 1109 1109 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 1118 1118 ! 1119 1119 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 1120 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)1121 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)1120 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 1121 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 1122 1122 ! needed to restart if land processor not computed 1123 1123 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 1133 1133 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 1134 1134 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1135 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)1135 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 1136 1136 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 1137 1137 l_1st_euler = .true. … … 1140 1140 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 1141 1141 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1142 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)1142 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 1143 1143 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 1144 1144 l_1st_euler = .true. … … 1165 1165 ! ! ----------------------- ! 1166 1166 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 1167 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)1168 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)1167 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 1168 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 1169 1169 ELSE ! one at least array is missing 1170 1170 tilde_e3t_b(:,:,:) = 0.0_wp … … 1175 1175 ! ! ------------ ! 1176 1176 IF( id5 > 0 ) THEN ! required array exists 1177 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)1177 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 1178 1178 ELSE ! array is missing 1179 1179 hdiv_lf(:,:,:) = 0.0_wp … … 1251 1251 ! ! =================== 1252 1252 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 1253 IF( lwxios ) CALL iom_swap( cwxios_context )1254 1253 ! ! --------- ! 1255 1254 ! ! all cases ! 1256 1255 ! ! --------- ! 1257 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)1258 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)1256 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 1257 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 1259 1258 ! ! ----------------------- ! 1260 1259 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 1261 1260 ! ! ----------------------- ! 1262 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)1263 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)1261 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 1262 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 1264 1263 END IF 1265 1264 ! ! -------------! 1266 1265 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 1267 1266 ! ! ------------ ! 1268 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)1267 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 1269 1268 ENDIF 1270 1269 ! 1271 IF( lwxios ) CALL iom_swap( cxios_context )1272 1270 ENDIF 1273 1271 ! -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/nemogcm.F90
r12983 r13984 383 383 CALL phy_cst ! Physical constants 384 384 385 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain385 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 386 386 387 387 IF( sn_cfctl%l_prtctl ) & -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/step.F90
r13458 r13984 304 304 IF( kstp == nitend .OR. indic < 0 ) THEN 305 305 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 306 IF(lrxios) CALL iom_context_finalize( cr xios_context )306 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 307 307 ENDIF 308 308 #endif -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/stepLF.F90
r13295 r13984 318 318 IF( kstp == nitend .OR. indic < 0 ) THEN 319 319 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 320 IF(lrxios) CALL iom_context_finalize( cr xios_context )320 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 321 321 ENDIF 322 322 #endif -
NEMO/branches/2020/SI3_vp_rheology/src/SWE/stpRK3.F90
r13295 r13984 361 361 IF( kstp == nitend .OR. indic < 0 ) THEN 362 362 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 363 IF(lrxios) CALL iom_context_finalize( cr xios_context )363 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 364 364 ENDIF 365 365 #endif -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/C14/trcsms_c14.F90
r13295 r13984 144 144 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 145 145 ! 146 CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) 147 CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) 146 CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) ! These five need & 147 CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) ! & to be written & 148 148 CALL iom_rstput( kt, nitrst, numrtw, 'exch_co2', exch_co2 ) ! & for temporal & 149 149 CALL iom_rstput( kt, nitrst, numrtw, 'exch_c14', exch_c14 ) ! & averages & 150 CALL iom_rstput( kt, nitrst, numrtw, 'qtr_c14', qtr_c14 )! & to be coherent.150 CALL iom_rstput( kt, nitrst, numrtw, 'qtr_c14', qtr_c14 ) ! & to be coherent. 151 151 CALL iom_rstput( kt, nitrst, numrtw, 'qint_c14', qint_c14 ) ! Cumulative 152 152 ! -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/PISCES/P4Z/p4zsms.F90
r13472 r13984 369 369 IF(lwp) WRITE(numout,*) '~~~~~~~' 370 370 ENDIF 371 CALL iom_rstput( kt, nitrst, numrtw, 'PH', hi(:,:,:) )372 CALL iom_rstput( kt, nitrst, numrtw, 'Silicalim', xksi(:,:) )371 CALL iom_rstput( kt, nitrst, numrtw, 'PH', hi(:,:,:) ) 372 CALL iom_rstput( kt, nitrst, numrtw, 'Silicalim', xksi(:,:) ) 373 373 CALL iom_rstput( kt, nitrst, numrtw, 'Silicamax', xksimax(:,:) ) 374 374 CALL iom_rstput( kt, nitrst, numrtw, 'tcflxcum', t_oce_co2_flx_cum ) -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/PISCES/SED/sed.F90
r10425 r13984 44 44 REAL , PUBLIC :: sedmask 45 45 REAL(wp), PUBLIC :: denssol !: density of solid material 46 INTEGER , PUBLIC :: numrsr, numrsw !: logical unit for sed restart (read and write)47 46 LOGICAL , PUBLIC :: lrst_sed !: logical to control the trc restart write 48 47 LOGICAL , PUBLIC :: ln_rst_sed = .TRUE. !: initialisation from a restart file or not -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/PISCES/SED/sedrst.F90
r13286 r13984 42 42 CHARACTER(LEN=50) :: clname ! trc output restart file name 43 43 CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file 44 CHARACTER(LEN=52) :: clpname ! trc output restart file name including AGRIF 44 45 !!---------------------------------------------------------------------- 45 46 ! … … 80 81 IF(lwp) WRITE(numsed,*) & 81 82 ' open sed restart.output NetCDF file: ',TRIM(clpath)//clname 82 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 83 IF(.NOT.lwxios) THEN 84 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 85 ELSE 86 #if defined key_iomput 87 cw_sedrst_cxt = "rstws_"//TRIM(ADJUSTL(clkt)) 88 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 89 clpname = clname 90 ELSE 91 clpname = TRIM(Agrif_CFixed())//"_"//clname 92 ENDIF 93 numrsw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 94 CALL iom_init( cw_sedrst_cxt, kdid = numrsw, ld_closedef = .FALSE. ) 95 #else 96 clinfo = 'Can not use XIOS in trc_rst_opn' 97 CALL ctl_stop(TRIM(clinfo)) 98 #endif 99 ENDIF 100 83 101 lrst_sed = .TRUE. 84 102 ENDIF … … 196 214 CALL pack_arr( jpoce, sedligand(1:jpoce,1:jpksed), & 197 215 & zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) 198 199 216 IF( ln_timing ) CALL timing_stop('sed_rst_read') 200 217 … … 240 257 !! 1. WRITE in nutwrs 241 258 !! ------------------ 242 243 zinfo(1) = REAL( kt) 244 CALL iom_rstput( kt, nitrst, numrsw, 'kt', zinfo ) 259 ! zinfo(1) = REAL( kt) 260 CALL iom_rstput( kt, nitrst, numrsw, 'kt', REAL( kt , wp) ) 245 261 246 262 ! Back to 2D geometry … … 299 315 300 316 IF( kt == nitrst ) THEN 301 CALL iom_close( numrsw ) ! close the restart file (only at last time step) 317 IF(.NOT.lwxios) THEN 318 CALL iom_close( numrsw ) ! close the restart file (only at last time step) 319 ELSE 320 CALL iom_context_finalize( cw_sedrst_cxt ) 321 iom_file(numrsw)%nfid = 0 322 numrsw = 0 323 ENDIF 302 324 IF( l_offline .AND. ln_rst_list ) THEN 303 325 nrst_lst = nrst_lst + 1 … … 342 364 REAL(wp) :: zkt, zrdttrc1 343 365 REAL(wp) :: zndastp 366 CHARACTER(len = 82) :: clpname 344 367 345 368 ! Time domain : restart … … 353 376 354 377 IF( ln_rst_sed ) THEN 378 lxios_sini = .FALSE. 355 379 CALL iom_open( TRIM(cn_sedrst_indir)//'/'//cn_sedrst_in, numrsr ) 380 381 IF( lrxios) THEN 382 cr_sedrst_cxt = 'sed_rst' 383 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for SED' 384 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 385 ! clpname = cn_sedrst_in 386 ! ELSE 387 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_sedrst_in 388 ! ENDIF 389 CALL iom_init( cr_sedrst_cxt, kdid = numrsr, ld_closedef = .TRUE. ) 390 ENDIF 356 391 CALL iom_get ( numrsr, 'kt', zkt ) ! last time-step of previous run 357 358 392 IF(lwp) THEN 359 393 WRITE(numsed,*) ' *** Info read in restart : ' … … 402 436 IF(lwp) WRITE(numsed,*) 'trc_wri : write the TOP restart file (NetCDF) at it= ', kt, ' date= ', ndastp 403 437 IF(lwp) WRITE(numsed,*) '~~~~~~~' 438 IF( lwxios ) CALL iom_init_closedef(cw_sedrst_cxt) 404 439 ENDIF 405 440 CALL iom_rstput( kt, nitrst, numrsw, 'kt' , REAL( kt , wp) ) ! time-step 406 441 CALL iom_rstput( kt, nitrst, numrsw, 'ndastp' , REAL( ndastp, wp) ) ! date 407 CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj 408 ! ! the begining of the run [s]442 CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj ) ! number of elapsed days since 443 ! ! the begining of the run [s] 409 444 ENDIF 410 445 -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/PISCES/SED/sedstp.F90
r12489 r13984 86 86 IF( kt == nitsed000 ) THEN 87 87 CALL iom_close( numrsr ) ! close input tracer restart file 88 ! IF(lwm) CALL FLUSH( numont ) ! flush namelist output 88 IF(lrxios) CALL iom_context_finalize( cr_sedrst_cxt ) 89 ! IF(lwm) CALL FLUSH( numont ) ! flush namelist output 89 90 ENDIF 90 91 IF( lrst_sed ) CALL sed_rst_wri( kt ) ! restart file output -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/TRP/trcadv.F90
r13286 r13984 22 22 USE traadv_cen ! centered scheme (tra_adv_cen routine) 23 23 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 24 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version) 24 25 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 26 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version) 25 27 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 26 28 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 124 126 ! 125 127 CASE ( np_CEN ) ! Centered : 2nd / 4th order 128 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kmm), 'T', 1.) 126 129 CALL tra_adv_cen( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v ) 127 130 CASE ( np_FCT ) ! FCT : 2nd / 4th order 128 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 131 IF (nn_hls.EQ.2) THEN 132 CALL lbc_lnk_multi( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1., ptr(:,:,:,:,Kmm), 'T', 1.) 133 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 134 #if defined key_loop_fusion 135 CALL tra_adv_fct_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 136 #else 137 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 138 #endif 139 ELSE 140 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 141 END IF 129 142 CASE ( np_MUS ) ! MUSCL 130 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 143 IF (nn_hls.EQ.2) THEN 144 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 145 #if defined key_loop_fusion 146 CALL tra_adv_mus_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 147 #else 148 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 149 #endif 150 ELSE 151 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 152 END IF 131 153 CASE ( np_UBS ) ! UBS 154 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 132 155 CALL tra_adv_ubs( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v ) 133 156 CASE ( np_QCK ) ! QUICKEST 157 IF (nn_hls.EQ.2) THEN 158 CALL lbc_lnk_multi( 'trcadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 159 CALL lbc_lnk( 'traadv', ptr(:,:,:,:,Kbb), 'T', 1.) 160 END IF 134 161 CALL tra_adv_qck( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs ) 135 162 ! -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/TRP/trcldf.F90
r13295 r13984 101 101 & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 ) 102 102 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: all operator (iso-level, -neutral) 103 IF(nn_hls.EQ.2) CALL lbc_lnk( 'trc_ldf', ptr(:,:,:,:,Kbb), 'T',1.) 103 104 CALL tra_ldf_blp ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, & 104 105 & ptr(:,:,:,:,Kbb) , ptr(:,:,:,:,Krhs), jptra, nldf_trc ) -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/trc.F90
r13558 r13984 21 21 INTEGER, PUBLIC :: numonr = -1 !: reference passive tracer namelist output output.namelist.top 22 22 INTEGER, PUBLIC :: numstr !: tracer statistics 23 INTEGER, PUBLIC :: numrtr = -1 !: trc restart (read )24 INTEGER, PUBLIC :: numrtw !: trc restart ( write )25 23 CHARACTER(:), ALLOCATABLE, PUBLIC :: numnat_ref !: character buffer for reference passive tracer namelist_top_ref 26 24 CHARACTER(:), ALLOCATABLE, PUBLIC :: numnat_cfg !: character buffer for configuration specific passive tracer namelist_top_cfg -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/trcrst.F90
r13558 r13984 52 52 CHARACTER(LEN=50) :: clname ! trc output restart file name 53 53 CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file 54 CHARACTER(LEN=50) :: clpname ! trc output restart file name including AGRIF 54 55 !!---------------------------------------------------------------------- 55 56 ! … … 91 92 IF(lwp) WRITE(numout,*) & 92 93 ' open trc restart.output NetCDF file: ',TRIM(clpath)//clname 93 CALL iom_open( TRIM(clpath)//TRIM(clname), numrtw, ldwrt = .TRUE. ) 94 IF(.NOT.lwxios) THEN 95 CALL iom_open( TRIM(clpath)//TRIM(clname), numrtw, ldwrt = .TRUE. ) 96 ELSE 97 #if defined key_iomput 98 cw_toprst_cxt = "rstwt_"//TRIM(ADJUSTL(clkt)) 99 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 100 clpname = clname 101 ELSE 102 clpname = TRIM(Agrif_CFixed())//"_"//clname 103 ENDIF 104 numrtw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 105 CALL iom_init( cw_toprst_cxt, kdid = numrtw, ld_closedef = .FALSE. ) 106 #else 107 clinfo = 'Can not use XIOS in trc_rst_opn' 108 CALL ctl_stop(TRIM(clinfo)) 109 #endif 110 ENDIF 94 111 lrst_trc = .TRUE. 95 112 ENDIF … … 121 138 END DO 122 139 ! 123 CALL iom_delay_rst( 'READ', 'TOP', numrtr ) ! read only TOP delayed global communication variables 124 140 IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'TOP', numrtr ) ! read only TOP delayed global communication variables 125 141 END SUBROUTINE trc_rst_read 126 142 … … 147 163 CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) ) 148 164 END DO 149 ! 150 CALL iom_delay_rst( 'WRITE', 'TOP', numrtw ) ! save only TOP delayed global communication variables165 166 IF( .NOT. lwxios ) CALL iom_delay_rst( 'WRITE', 'TOP', numrtw ) ! save only TOP delayed global communication variables 151 167 152 168 IF( kt == nitrst ) THEN 153 169 CALL trc_rst_stat( Kmm, Krhs ) ! statistics 154 CALL iom_close( numrtw ) ! close the restart file (only at last time step) 170 IF(lwxios) THEN 171 CALL iom_context_finalize( cw_toprst_cxt ) 172 iom_file(numrtw)%nfid = 0 173 numrtw = 0 174 ELSE 175 CALL iom_close( numrtw ) ! close the restart file (only at last time step) 176 ENDIF 155 177 #if ! defined key_trdmxl_trc 156 178 lrst_trc = .FALSE. … … 196 218 REAL(wp) :: zrdttrc1, zkt, zndastp, zdayfrac, ksecs, ktime 197 219 INTEGER :: ihour, iminute 220 CHARACTER(len=82) :: clpname 198 221 199 222 ! Time domain : restart … … 207 230 208 231 IF( ln_rsttr ) THEN 232 lxios_sini = .FALSE. 209 233 CALL iom_open( TRIM(cn_trcrst_indir)//'/'//cn_trcrst_in, numrtr ) 234 IF( lrxios) THEN 235 cr_toprst_cxt = 'top_rst' 236 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for TOP' 237 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 238 ! clpname = cn_trcrst_in 239 ! ELSE 240 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_trcrst_in 241 ! ENDIF 242 CALL iom_init( cr_toprst_cxt, kdid = numrtr, ld_closedef = .TRUE. ) 243 ENDIF 244 210 245 CALL iom_get ( numrtr, 'kt', zkt ) ! last time-step of previous run 211 246 … … 293 328 IF(lwp) WRITE(numout,*) '~~~~~~~' 294 329 ENDIF 295 CALL iom_rstput( kt, nitrst, numrtw, 'kt' , REAL( kt , wp) ) ! time-step296 CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) ) ! date297 CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj ) ! number of elapsed days since330 CALL iom_rstput( kt, nitrst, numrtw, 'kt' , REAL( kt , wp) ) ! time-step 331 CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) ) ! date 332 CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj ) ! number of elapsed days since 298 333 ! ! the begining of the run [s] 299 CALL iom_rstput( kt, nitrst, numrtw, 'ntime' , REAL( nn_time0, wp) ) ! time334 CALL iom_rstput( kt, nitrst, numrtw, 'ntime' , REAL( nn_time0, wp) ) ! time 300 335 ENDIF 301 336 -
NEMO/branches/2020/SI3_vp_rheology/src/TOP/trcstp.F90
r13286 r13984 110 110 IF( kt == nittrc000 ) THEN 111 111 CALL iom_close( numrtr ) ! close input tracer restart file 112 IF(lrxios) CALL iom_context_finalize( cr_toprst_cxt ) 112 113 IF(lwm) CALL FLUSH( numont ) ! flush namelist output 113 114 ENDIF … … 196 197 & .AND. iom_varid( numrtr, 'ktdcy' , ldstop = .FALSE. ) > 0 & 197 198 & .AND. iom_varid( numrtr, 'nrdcy' , ldstop = .FALSE. ) > 0 ) THEN 198 199 199 CALL iom_get( numrtr, 'ktdcy', zkt ) 200 200 rsecfst = INT( zkt ) * rn_Dt -
NEMO/branches/2020/SI3_vp_rheology/tests/CANAL/MY_SRC/domvvl.F90
r13458 r13984 282 282 ENDIF 283 283 ! 284 IF(lwxios) THEN285 ! define variables in restart file when writing with XIOS286 CALL iom_set_rstw_var_active('e3t_b')287 CALL iom_set_rstw_var_active('e3t_n')288 ! ! ----------------------- !289 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !290 ! ! ----------------------- !291 CALL iom_set_rstw_var_active('tilde_e3t_b')292 CALL iom_set_rstw_var_active('tilde_e3t_n')293 END IF294 ! ! -------------!295 IF( ln_vvl_ztilde ) THEN ! z_tilde case !296 ! ! ------------ !297 CALL iom_set_rstw_var_active('hdiv_lf')298 ENDIF299 !300 ENDIF301 !302 284 END SUBROUTINE dom_vvl_zgr 303 285 … … 803 785 IF( ln_rstart ) THEN !* Read the restart file 804 786 CALL rst_read_open ! open the restart file if necessary 805 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)787 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 806 788 ! 807 789 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 816 798 ! 817 799 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 818 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)819 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)800 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 801 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 820 802 ! needed to restart if land processor not computed 821 803 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 831 813 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 832 814 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 833 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)815 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 834 816 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 835 817 l_1st_euler = .true. … … 838 820 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 839 821 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 840 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)822 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 841 823 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 842 824 l_1st_euler = .true. … … 863 845 ! ! ----------------------- ! 864 846 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 865 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)866 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)847 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 848 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 867 849 ELSE ! one at least array is missing 868 850 tilde_e3t_b(:,:,:) = 0.0_wp … … 873 855 ! ! ------------ ! 874 856 IF( id5 > 0 ) THEN ! required array exists 875 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)857 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 876 858 ELSE ! array is missing 877 859 hdiv_lf(:,:,:) = 0.0_wp … … 947 929 ! ! =================== 948 930 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 949 IF( lwxios ) CALL iom_swap( cwxios_context )950 931 ! ! --------- ! 951 932 ! ! all cases ! 952 933 ! ! --------- ! 953 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)954 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)934 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 935 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 955 936 ! ! ----------------------- ! 956 937 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 957 938 ! ! ----------------------- ! 958 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)959 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)939 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 940 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 960 941 END IF 961 942 ! ! -------------! 962 943 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 963 944 ! ! ------------ ! 964 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)945 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 965 946 ENDIF 966 947 ! 967 IF( lwxios ) CALL iom_swap( cxios_context )968 948 ENDIF 969 949 ! -
NEMO/branches/2020/SI3_vp_rheology/tests/CANAL/MY_SRC/trazdf.F90
r13295 r13984 54 54 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 55 55 ! 56 INTEGER :: j k ! Dummy loop indices56 INTEGER :: ji, jj, jk ! Dummy loop indices 57 57 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace 58 58 !!--------------------------------------------------------------------- … … 61 61 ! 62 62 IF( kt == nit000 ) THEN 63 IF(lwp)WRITE(numout,*) 64 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 65 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 63 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 64 IF(lwp)WRITE(numout,*) 65 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 66 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 67 ENDIF 66 68 ENDIF 67 69 ! … … 83 85 84 86 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics 85 DO jk = 1, jpkm1 86 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 87 & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrdt(:,:,jk) 88 ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 89 & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrds(:,:,jk) 87 DO jk = 1, jpk 88 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) & 89 & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 90 & / ( e3t(:,:,jk,Kmm)*rDt ) ) & 91 & - ztrdt(:,:,jk) 92 ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) & 93 & - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 94 & / ( e3t(:,:,jk,Kmm)*rDt ) ) & 95 & - ztrds(:,:,jk) 90 96 END DO 91 97 !!gm this should be moved in trdtra.F90 and done on all trends … … 135 141 INTEGER :: ji, jj, jk, jn ! dummy loop indices 136 142 REAL(wp) :: zrhs, zzwi, zzws ! local scalars 137 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwi, zwt, zwd, zws143 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws 138 144 !!--------------------------------------------------------------------- 139 145 ! … … 149 155 ! 150 156 ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 151 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ; zwt(:,:,2:jpk) = avt(:,:,2:jpk) 152 ELSE ; zwt(:,:,2:jpk) = avs(:,:,2:jpk) 157 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 158 DO_3D( 1, 1, 1, 1, 2, jpk ) 159 zwt(ji,jj,jk) = avt(ji,jj,jk) 160 END_3D 161 ELSE 162 DO_3D( 1, 1, 1, 1, 2, jpk ) 163 zwt(ji,jj,jk) = avs(ji,jj,jk) 164 END_3D 153 165 ENDIF 154 166 zwt(:,:,1) = 0._wp -
NEMO/branches/2020/SI3_vp_rheology/tests/ISOMIP+/MY_SRC/dtatsd.F90
r13583 r13984 18 18 USE phycst ! physical constants 19 19 USE dom_oce ! ocean space and time domain 20 USE domain, ONLY : dom_tile 20 21 USE fldread ! read input fields 21 22 ! … … 163 164 INTEGER , INTENT(in ) :: kt ! ocean time-step 164 165 CHARACTER(LEN=3) , INTENT(in ) :: cddta ! dmp or ini 165 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts), INTENT( out) :: ptsd ! T & S data166 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data 166 167 ! 167 168 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 168 169 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 170 INTEGER :: itile 169 171 REAL(wp):: zl, zi ! local scalars 170 172 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace 171 173 !!---------------------------------------------------------------------- 172 174 ! 175 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 176 itile = ntile 177 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 178 179 SELECT CASE(cddta) 180 CASE('ini') 181 CALL fld_read( kt, 1, sf_tsdini ) !== read T & S data at kt time step ==! 182 CASE('dmp') 183 CALL fld_read( kt, 1, sf_tsddmp ) !== read T & S data at kt time step ==! 184 CASE DEFAULT 185 CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') 186 END SELECT 187 188 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 189 ENDIF 190 ! 173 191 SELECT CASE(cddta) 174 CASE('ini') 175 CALL fld_read( kt, 1, sf_tsdini ) !== read T & S data at kt time step ==! 176 ptsd(:,:,:,jp_tem) = sf_tsdini(jp_tem)%fnow(:,:,:) ! NO mask 177 ptsd(:,:,:,jp_sal) = sf_tsdini(jp_sal)%fnow(:,:,:) 192 CASE('ini') 193 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 194 ptsd(ji,jj,jk,jp_tem) = sf_tsdini(jp_tem)%fnow(ji,jj,jk) ! NO mask 195 ptsd(ji,jj,jk,jp_sal) = sf_tsdini(jp_sal)%fnow(ji,jj,jk) 196 END_3D 178 197 CASE('dmp') 179 CALL fld_read( kt, 1, sf_tsddmp ) !== read T & S data at kt time step ==! 180 ptsd(:,:,:,jp_tem) = sf_tsddmp(jp_tem)%fnow(:,:,:) ! NO mask 181 ptsd(:,:,:,jp_sal) = sf_tsddmp(jp_sal)%fnow(:,:,:) 198 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 199 ptsd(ji,jj,jk,jp_tem) = sf_tsddmp(jp_tem)%fnow(ji,jj,jk) ! NO mask 200 ptsd(ji,jj,jk,jp_sal) = sf_tsddmp(jp_sal)%fnow(ji,jj,jk) 201 END_3D 182 202 CASE DEFAULT 183 203 CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') … … 186 206 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! 187 207 ! 188 IF( kt == nit000 .AND. lwp )THEN 189 WRITE(numout,*) 190 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 208 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 209 IF( kt == nit000 .AND. lwp )THEN 210 WRITE(numout,*) 211 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 212 ENDIF 191 213 ENDIF 192 214 ! … … 220 242 ELSE !== z- or zps- coordinate ==! 221 243 ! 222 ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:) ! Mask 223 ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) 244 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 245 ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! Mask 246 ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 247 END_3D 224 248 ! 225 249 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level -
NEMO/branches/2020/SI3_vp_rheology/tests/ISOMIP+/MY_SRC/eosbn2.F90
r13583 r13984 39 39 !!---------------------------------------------------------------------- 40 40 USE dom_oce ! ocean space and time domain 41 USE domutl, ONLY : is_tile 41 42 USE phycst ! physical constants 42 43 USE stopar ! Stochastic T/S fluctuations … … 191 192 192 193 SUBROUTINE eos_insitu( pts, prd, pdep ) 194 !! 195 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 196 ! ! 2 : salinity [psu] 197 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 198 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 199 !! 200 CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) 201 END SUBROUTINE eos_insitu 202 203 SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) 193 204 !!---------------------------------------------------------------------- 194 205 !! *** ROUTINE eos_insitu *** … … 228 239 !! TEOS-10 Manual, 2010 229 240 !!---------------------------------------------------------------------- 230 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 241 INTEGER , INTENT(in ) :: ktts, ktrd, ktdep 242 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 231 243 ! ! 2 : salinity [psu] 232 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT( out) :: prd ! in situ density [-]233 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pdep ! depth [m]244 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 245 REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] 234 246 ! 235 247 INTEGER :: ji, jj, jk ! dummy loop indices … … 312 324 IF( ln_timing ) CALL timing_stop('eos-insitu') 313 325 ! 314 END SUBROUTINE eos_insitu 326 END SUBROUTINE eos_insitu_t 315 327 316 328 317 329 SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 330 !! 331 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 332 ! ! 2 : salinity [psu] 333 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 334 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) 335 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 336 !! 337 CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) 338 END SUBROUTINE eos_insitu_pot 339 340 341 SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) 318 342 !!---------------------------------------------------------------------- 319 343 !! *** ROUTINE eos_insitu_pot *** … … 328 352 !! 329 353 !!---------------------------------------------------------------------- 330 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 354 INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep 355 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 331 356 ! ! 2 : salinity [psu] 332 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT( out) :: prd ! in situ density [-]333 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT( out) :: prhop ! potential density (surface referenced)334 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pdep ! depth [m]357 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 358 REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) 359 REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] 335 360 ! 336 361 INTEGER :: ji, jj, jk, jsmp ! dummy loop indices … … 482 507 IF( ln_timing ) CALL timing_stop('eos-pot') 483 508 ! 484 END SUBROUTINE eos_insitu_pot 509 END SUBROUTINE eos_insitu_pot_t 485 510 486 511 487 512 SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 513 !! 514 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 515 ! ! 2 : salinity [psu] 516 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 517 REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density 518 !! 519 CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) 520 END SUBROUTINE eos_insitu_2d 521 522 523 SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) 488 524 !!---------------------------------------------------------------------- 489 525 !! *** ROUTINE eos_insitu_2d *** … … 496 532 !! 497 533 !!---------------------------------------------------------------------- 498 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 534 INTEGER , INTENT(in ) :: ktts, ktdep, ktrd 535 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 499 536 ! ! 2 : salinity [psu] 500 REAL(wp), DIMENSION( jpi,jpj), INTENT(in ) :: pdep ! depth [m]501 REAL(wp), DIMENSION( jpi,jpj), INTENT( out) :: prd ! in situ density537 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 538 REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density 502 539 ! 503 540 INTEGER :: ji, jj, jk ! dummy loop indices … … 584 621 IF( ln_timing ) CALL timing_stop('eos2d') 585 622 ! 586 END SUBROUTINE eos_insitu_2d 623 END SUBROUTINE eos_insitu_2d_t 587 624 588 625 589 626 SUBROUTINE rab_3d( pts, pab, Kmm ) 627 !! 628 INTEGER , INTENT(in ) :: Kmm ! time level index 629 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 630 REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 631 !! 632 CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 633 END SUBROUTINE rab_3d 634 635 636 SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 590 637 !!---------------------------------------------------------------------- 591 638 !! *** ROUTINE rab_3d *** … … 598 645 !!---------------------------------------------------------------------- 599 646 INTEGER , INTENT(in ) :: Kmm ! time level index 600 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 601 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 647 INTEGER , INTENT(in ) :: ktts, ktab 648 REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 649 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 602 650 ! 603 651 INTEGER :: ji, jj, jk ! dummy loop indices … … 706 754 IF( ln_timing ) CALL timing_stop('rab_3d') 707 755 ! 708 END SUBROUTINE rab_3d 756 END SUBROUTINE rab_3d_t 709 757 710 758 711 759 SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 760 !! 761 INTEGER , INTENT(in ) :: Kmm ! time level index 762 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 763 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 764 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 765 !! 766 CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 767 END SUBROUTINE rab_2d 768 769 770 SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 712 771 !!---------------------------------------------------------------------- 713 772 !! *** ROUTINE rab_2d *** … … 718 777 !!---------------------------------------------------------------------- 719 778 INTEGER , INTENT(in ) :: Kmm ! time level index 720 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 721 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 722 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 779 INTEGER , INTENT(in ) :: ktts, ktdep, ktab 780 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 781 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 782 REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 723 783 ! 724 784 INTEGER :: ji, jj, jk ! dummy loop indices … … 829 889 IF( ln_timing ) CALL timing_stop('rab_2d') 830 890 ! 831 END SUBROUTINE rab_2d 891 END SUBROUTINE rab_2d_t 832 892 833 893 … … 942 1002 943 1003 SUBROUTINE bn2( pts, pab, pn2, Kmm ) 1004 !! 1005 INTEGER , INTENT(in ) :: Kmm ! time level index 1006 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 1007 REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 1008 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 1009 !! 1010 CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 1011 END SUBROUTINE bn2 1012 1013 1014 SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 944 1015 !!---------------------------------------------------------------------- 945 1016 !! *** ROUTINE bn2 *** … … 956 1027 !!---------------------------------------------------------------------- 957 1028 INTEGER , INTENT(in ) :: Kmm ! time level index 1029 INTEGER , INTENT(in ) :: ktab, ktn2 958 1030 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 959 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]960 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]1031 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 1032 REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 961 1033 ! 962 1034 INTEGER :: ji, jj, jk ! dummy loop indices … … 982 1054 IF( ln_timing ) CALL timing_stop('bn2') 983 1055 ! 984 END SUBROUTINE bn2 1056 END SUBROUTINE bn2_t 985 1057 986 1058 … … 1043 1115 1044 1116 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 1117 !! 1118 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 1119 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1120 REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] 1121 !! 1122 CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 1123 END SUBROUTINE eos_fzp_2d 1124 1125 1126 SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) 1045 1127 !!---------------------------------------------------------------------- 1046 1128 !! *** ROUTINE eos_fzp *** … … 1054 1136 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 1055 1137 !!---------------------------------------------------------------------- 1138 INTEGER , INTENT(in ) :: kttf 1056 1139 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 1057 1140 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1058 REAL(wp), DIMENSION( jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celsius]1141 REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] 1059 1142 ! 1060 1143 INTEGER :: ji, jj ! dummy loop indices … … 1089 1172 END SELECT 1090 1173 ! 1091 END SUBROUTINE eos_fzp_2d 1174 END SUBROUTINE eos_fzp_2d_t 1092 1175 1093 1176 -
NEMO/branches/2020/SI3_vp_rheology/tests/ISOMIP+/MY_SRC/tradmp.F90
r13295 r13984 95 95 ! 96 96 INTEGER :: ji, jj, jk, jn ! dummy loop indices 97 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts) :: zts_dta97 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta 98 98 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts 99 99 !!---------------------------------------------------------------------- -
NEMO/branches/2020/SI3_vp_rheology/tests/VORTEX/MY_SRC/domvvl.F90
r13458 r13984 282 282 ENDIF 283 283 ! 284 IF(lwxios) THEN285 ! define variables in restart file when writing with XIOS286 CALL iom_set_rstw_var_active('e3t_b')287 CALL iom_set_rstw_var_active('e3t_n')288 ! ! ----------------------- !289 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !290 ! ! ----------------------- !291 CALL iom_set_rstw_var_active('tilde_e3t_b')292 CALL iom_set_rstw_var_active('tilde_e3t_n')293 END IF294 ! ! -------------!295 IF( ln_vvl_ztilde ) THEN ! z_tilde case !296 ! ! ------------ !297 CALL iom_set_rstw_var_active('hdiv_lf')298 ENDIF299 !300 ENDIF301 !302 284 END SUBROUTINE dom_vvl_zgr 303 285 … … 803 785 IF( ln_rstart ) THEN !* Read the restart file 804 786 CALL rst_read_open ! open the restart file if necessary 805 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)787 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 806 788 ! 807 789 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 816 798 ! 817 799 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 818 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)819 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)800 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 801 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 820 802 ! needed to restart if land processor not computed 821 803 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 831 813 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 832 814 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 833 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)815 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 834 816 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 835 817 l_1st_euler = .true. … … 838 820 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 839 821 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 840 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)822 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 841 823 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 842 824 l_1st_euler = .true. … … 863 845 ! ! ----------------------- ! 864 846 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 865 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)866 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)847 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 848 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 867 849 ELSE ! one at least array is missing 868 850 tilde_e3t_b(:,:,:) = 0.0_wp … … 873 855 ! ! ------------ ! 874 856 IF( id5 > 0 ) THEN ! required array exists 875 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)857 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 876 858 ELSE ! array is missing 877 859 hdiv_lf(:,:,:) = 0.0_wp … … 947 929 ! ! =================== 948 930 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 949 IF( lwxios ) CALL iom_swap( cwxios_context )950 931 ! ! --------- ! 951 932 ! ! all cases ! 952 933 ! ! --------- ! 953 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)954 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)934 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 935 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 955 936 ! ! ----------------------- ! 956 937 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 957 938 ! ! ----------------------- ! 958 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)959 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)939 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 940 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 960 941 END IF 961 942 ! ! -------------! 962 943 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 963 944 ! ! ------------ ! 964 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)945 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 965 946 ENDIF 966 947 ! 967 IF( lwxios ) CALL iom_swap( cxios_context )968 948 ENDIF 969 949 !
Note: See TracChangeset
for help on using the changeset viewer.