New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 13992 for NEMO/branches – NEMO

Changeset 13992 for NEMO/branches


Ignore:
Timestamp:
2020-12-02T14:29:08+01:00 (3 years ago)
Author:
gsamson
Message:

update dev_r2052_ENHANCE-09_rbourdal_massfluxconvection branch with trunk@r13991

Location:
NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection
Files:
113 edited
6 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection

    • Property svn:externals

      •  

        old new  
        88 
        99# SETTE 
        10 ^/utils/CI/sette@13795        sette 
         10^/utils/CI/sette_MPI3_LoopFusion@13943         sette 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/cfgs/SHARED/namelist_ref

    r13826 r13992  
    9494   ln_use_jattr = .false.    !  use (T) the file attribute: open_ocean_jstart, if present 
    9595   !                         !  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 
    96103/ 
    97104!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/latex/NEMO/main/bibliography.bib

    r12377 r13992  
    19061906} 
    19071907 
     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 
    19081918@article{         losch_JGR08, 
    19091919  title         = "Modeling ice shelf cavities in a z coordinate Ocean 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/latex/NEMO/subfiles/chap_DIA.tex

    r12377 r13992  
    119119\subsection{XIOS: Reading and writing restart file} 
    120120 
    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} 
     121XIOS may be used to read single file restart produced by \NEMO. The variables written to 
     122file \forcode{numror} (OCE), \forcode{numrir} (SI3), \forcode{numrtr} (TOP), \forcode{numrsr} (SED) can be handled by XIOS.  
     123To activate restart reading using XIOS, set \np[=.true. ]{ln_xios_read}{ln\_xios\_read} 
    123124in \textit{namelist\_cfg}. This setting will be ignored when multiple restart files are present, and default \NEMO 
    124125functionality will be used for reading. There is no need to change iodef.xml file to use XIOS to read 
    … …  
    142143have to be rebuild before continuing the run. This option aims to reduce number of restart files generated by \NEMO\ only, 
    143144and 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}) and 
    148 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 subroutine 
    151 \rou{iom\_set\_rstw\_core} (\mdl{iom}) or by calling  \rou{iom\_set\_rstw\_active} (\mdl{iom}) with the name of a variable 
    152 as an argument. This convention follows approach for writing restart using iom, where variables are 
    153 written either by \rou{rst\_write} or by calling \rou{iom\_rstput} from individual routines. 
    154 \end{enumerate} 
    155145 
    156146An older versions of XIOS do not support reading functionality. It's recommended to use at least XIOS2@1451. 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/latex/NEMO/subfiles/chap_DYN.tex

    r11693 r13992  
    12451245the atmospheric pressure is taken into account when computing the surface pressure gradient. 
    12461246 
    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}), 
    12481248the tidal potential is taken into account when computing the surface pressure gradient. 
    12491249 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/latex/NEMO/subfiles/chap_LBC.tex

    r11693 r13992  
    1616    Release & Author(s) & Modifications \\ 
    1717    \hline 
     18    {\em  next} & {\em Simon M{\" u}ller} & {\em Minor update of \autoref{subsec:LBC_bdy_tides}} \\[2mm] 
    1819    {\em   4.0} & {\em ...} & {\em ...} \\ 
    1920    {\em   3.6} & {\em ...} & {\em ...} \\ 
    … …  
    665666 
    666667Tidal 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 
     668tides (i.e., in \nam{_tide}{\_tide}, \np[=.true.]{ln_tide}{ln\_tide} with the active tidal 
     669constituents 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 
    671671the complex harmonic amplitudes of elevation (SSH) and barotropic 
    672 velocity (u,v) at open boundaries are defined through the 
    673 \nam{bdy_tide}{bdy\_tide} namelist parameters.\\ 
     672velocity components (u,v) at the open boundaries are defined through the 
     673\nam{bdy_tide}{bdy\_tide} namelist parameters.\par 
    674674 
    675675The tidal harmonic data at open boundaries can be specified in two 
    676676different ways, either on a two-dimensional grid covering the entire 
    677677model 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. 
     678be selected by setting \np[=.true.]{ln_bdytide_2ddta}{ln\_bdytide\_2ddta} or 
     679\np[=.false.]{ln_bdytide_2ddta}{ln\_bdytide\_2ddta}, respectively. In either 
     680case, the real and imaginary parts of SSH, u, and v amplitudes associated with 
     681each activated tidal constituent \texttt{<constituent>} have to be provided 
     682separately 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 
     685SSH, 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, 
     691variables \texttt{z1} and \texttt{z2} (real and imaginary part of SSH) are 
     692expected to be available in file \ifile{<input><constituent>\_grid\_T}, 
     693variables \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 
    701697 
    702698Note that the barotropic velocity components are assumed to be defined 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/latex/NEMO/subfiles/chap_SBC.tex

    r13165 r13992  
    55\begin{document} 
    66 
    7 \chapter{Surface Boundary Condition (SBC, SAS, ISF, ICB)} 
     7\chapter{Surface Boundary Condition (SBC, SAS, ISF, ICB, TDE)} 
    88\label{chap:SBC} 
    99 
    … …  
    1818    Release & Author(s) & Modifications \\ 
    1919    \hline 
     20    {\em  next} & {\em Simon M{\" u}ller} & {\em Update of \autoref{sec:SBC_TDE}}\\[2mm] 
    2021    {\em   4.0} & {\em ...} & {\em ...} \\ 
    2122    {\em   3.6} & {\em ...} & {\em ...} \\ 
    … …  
    10131014 
    10141015%% ================================================================================================= 
    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} 
    10171018 
    10181019\begin{listing} 
    … …  
    10221023\end{listing} 
    10231024 
    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} 
     1026Ocean model component TDE provides the common functionality for tidal forcing 
     1027and tidal analysis in the model framework. This includes the computation of the gravitational 
     1028surface 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 
     1031activated with \np[=.true.]{ln_tide}{ln\_tide} in namelist 
     1032\nam{_tide}{\_tide}. It provides the same 34 tidal constituents that are 
     1033included 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, 
     1036M2, S2, N2, K2, nu2, mu2, 2N2, L2, T2, eps2, lam2, R2, M3, MKS2, MN4, MS4, M4, 
     1037N4, S4, M6, and M8; see file \hf{tide} and \mdl{tide\_mod} for further 
     1038information 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 
     1044names in namelist array \np{sn_tide_cnames}{sn\_tide\_cnames}.\par 
     1045 
     1046\subsection{Surface tidal forcing} 
     1047Surface tidal forcing can be represented in the model through an additional 
     1048barotropic force in the momentum equation (\autoref{eq:MB_PE_dyn}) such that: 
    10271049\[ 
    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}) 
    10311052\] 
    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. 
     1053where $\gamma \Pi_{eq}$ stands for the equilibrium tidal forcing scaled by a spatially 
     1054uniform tilt factor $\gamma$, and $\Pi_{sal}$ is an optional 
     1055self-attraction and loading term (SAL). These additional terms are enabled when, 
     1056in addition to \np[=.true.]{ln_tide}{ln\_tide}), 
     1057\np[=.true.]{ln_tide_pot}{ln\_tide\_pot}.\par 
     1058 
     1059The equilibrium tidal forcing is expressed as a sum over the subset of 
     1060constituents 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} 
     1068to select the four tidal constituents of strongest equilibrium tidal 
     1069potential). The tidal tilt factor $\gamma = 1 + k - h$ includes the 
     1070Love numbers $k$ and $h$ \citep{love_prsla1909}; this factor is 
     1071configurable using \np{rn_tide_gamma} (default value 0.7). Optionally, 
     1072when \np[=.true.]{ln_tide_ramp}{ln\_tide\_ramp}, the equilibrium tidal 
     1073forcing 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 
    10471075 
    10481076The SAL term should in principle be computed online as it depends on 
    10491077the 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 
     1078discussion about the practical implementation of this term). The complex 
     1079calculations involved in such computations, however, are computationally very 
     1080expensive. Here, two mutually exclusive simpler variants are available: 
     1081amplitudes generated by an external model for oscillatory $\Pi_{sal}$ 
     1082contributions 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 
     1085tidal-constituent name and suffixes \forcode{_z1} and \forcode{_z2} for the two 
     1086orthogonal components, respectively); alternatively, a ``scalar approximation'' 
     1087can be used (\np[=.true.]{ln_scal_load}{ln\_scal\_load}), where 
    10561088\[ 
    10571089  \Pi_{sal} = \beta \eta, 
    10581090\] 
    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. 
     1091with a spatially uniform coefficient $\beta$, which can be configured 
     1092via \np{rn_scal_load}{rn\_scal\_load} (default value 0.094) and is 
     1093often tuned to minimize tidal prediction errors.\par 
     1094 
     1095For diagnostic purposes, the forcing potential of the individual tidal 
     1096constituents (incl. load ptential, if activated) and the total forcing 
     1097potential (incl. load potential, if activated) can be made available 
     1098as diagnostic output by setting 
     1099\np[=.true.]{ln_tide_dia}{ln\_tide\_dia} (fields 
     1100\forcode{tide_pot_<constituent>} and \forcode{tide_pot}).\par 
    10631101 
    10641102%% ================================================================================================= 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/namelists/nam_tide

    r10075 r13992  
    33!----------------------------------------------------------------------- 
    44   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 
    610         ln_scal_load  = .false.               ! Use scalar approximation for 
    711            rn_scal_load = 0.094               !     load potential 
    812         ln_read_load  = .false.               ! Or read load potential from file 
    913            cn_tide_load = 'tide_LOAD_grid_T.nc'  ! filename for load potential 
    10             !       
     14            ! 
    1115      ln_tide_ramp  = .false.               !  Use linear ramp for tides at startup 
    12          rdttideramp   =    0.                 !  ramp duration in days 
    13       clname(1)    = 'DUMMY'               !  name of constituent - all tidal components must be set in namelist_cfg 
     16         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 
    1418/ 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/doc/namelists/nambdy_tide

    r10075 r13992  
    44   filtide          = 'bdydta/amm12_bdytide_'   !  file name root of tidal forcing files 
    55   ln_bdytide_2ddta = .false.                   ! 
    6    ln_bdytide_conj  = .false.                   !  
    76/ 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/ICE/icedia.F90

    r13286 r13992  
    261261         ! Write in numriw (if iter == nitrst) 
    262262         ! ------------------  
    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    ) 
    268268         CALL iom_rstput( iter, nitrst, numriw, 'vol_loc_ini', vol_loc_ini ) 
    269269         CALL iom_rstput( iter, nitrst, numriw, 'tem_loc_ini', tem_loc_ini ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/ICE/icedyn_adv_pra.F90

    r13637 r13992  
    989989            DO jk = 1, nlay_s 
    990990               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(:,:,:) 
    9961001            END DO 
    9971002            !                                                        ! ice layers heat content 
    9981003            DO jk = 1, nlay_i 
    9991004               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(:,:,:) 
    10051015            END DO 
    10061016            ! 
    … …  
    10671077         ! 
    10681078         !                                                           ! 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) 
    10741084         !                                                           ! 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 ) 
    10801090         !                                                           ! 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  ) 
    10861096         !                                                           ! 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) 
    10921102         !                                                           ! 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) 
    10981108         !                                                           ! snow layers heat content 
    10991109         DO jk = 1, nlay_s 
    11001110            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) 
    11061121         END DO 
    11071122         !                                                           ! ice layers heat content 
    11081123         DO jk = 1, nlay_i 
    11091124            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) 
    11151135         END DO 
    11161136         ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/ICE/icedyn_rhg_evp.F90

    r13612 r13992  
    199199         zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
    200200      END_2D 
    201       CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) 
     201      CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp) 
    202202 
    203203      ! Lateral boundary conditions on velocity (modify zfmask) 
    … …  
    10331033         iter = kt + nn_fsbc - 1             ! ice restarts are written at kt == nitrst - nn_fsbc + 1 
    10341034         ! 
    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 ) 
    10371037         CALL iom_rstput( iter, nitrst, numriw, 'stress12_i', stress12_i ) 
    10381038         ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/ICE/icerst.F90

    r13472 r13992  
    5555      CHARACTER(len=50)   ::   clname   ! ice output restart file name 
    5656      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 
    5758      !!---------------------------------------------------------------------- 
    5859      ! 
    … …  
    8485            ENDIF 
    8586            ! 
    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 
    87105            lrst_ice = .TRUE. 
    88106         ENDIF 
    … …  
    117135         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~'          
    118136      ENDIF 
    119  
     137       
    120138      ! Write in numriw (if iter == nitrst) 
    121139      ! ------------------  
    … …  
    123141      CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) )      ! time-step  
    124142      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 
    126145 
    127146      ! Prognostic variables 
    … …  
    154173      IF( ln_cpl ) THEN 
    155174         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 ) 
    157176      ENDIF 
    158177      ! 
    … …  
    161180      ! ------------------ 
    162181      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 
    164189         lrst_ice = .FALSE. 
    165190      ENDIF 
    … …  
    181206      CHARACTER(len=2)  ::   zchar, zchar1 
    182207      REAL(wp)          ::   zfice, ziter 
     208      CHARACTER(lc)     ::   clpname 
    183209      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z3d   ! 3D workspace 
    184210      !!---------------------------------------------------------------------- 
    … …  
    190216      ENDIF 
    191217 
     218      lxios_sini = .FALSE. 
    192219      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 
    193231 
    194232      ! test if v_i exists  
    … …  
    198236      IF( id0 > 0 ) THEN   ! == case of a normal restart == ! 
    199237         !                 ! ------------------------------ ! 
    200           
    201238         ! Time info 
    202239         CALL iom_get( numrir, 'nn_fsbc', zfice ) 
    … …  
    278315         ENDIF 
    279316 
    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 
    282318         !                 ! ---------------------------------- ! 
    283319      ELSE                 ! == case of a simplified restart == ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/ICE/icestp.F90

    r13721 r13992  
    291291      tn_ice(:,:,:) = t_su(:,:,:)      ! initialisation of surface temp for coupled simu 
    292292      ! 
    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 
    294297      ! 
    295298   END SUBROUTINE ice_init 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ASM/asminc.F90

    r13295 r13992  
    2626   USE par_oce         ! Ocean space and time domain variables 
    2727   USE dom_oce         ! Ocean space and time domain 
     28   USE domain, ONLY : dom_tile 
    2829   USE domvvl          ! domain: variable volume level 
    2930   USE ldfdyn          ! lateral diffusion: eddy viscosity coefficients 
    … …  
    518519      ! 
    519520      INTEGER  :: ji, jj, jk 
    520       INTEGER  :: it 
     521      INTEGER  :: it, itile 
    521522      REAL(wp) :: zincwgt  ! IAU weight for current time step 
    522       REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values 
     523      REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values 
    523524      !!---------------------------------------------------------------------- 
    524525      ! 
    525526      ! freezing point calculation taken from oc_fz_pt (but calculated for all depths)  
    526527      ! 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 
    530533         ! 
    531534         !                             !-------------------------------------- 
    … …  
    538541            zincwgt = wgtiau(it) / rn_Dt   ! IAU weight for the current time step 
    539542            ! 
    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 
    544549            ENDIF 
    545550            ! 
    … …  
    548553               IF (ln_temnofreeze) THEN 
    549554                  ! 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) * zincwgt   
     555                  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 
    553558                  END WHERE 
    554559               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 
    556563               ENDIF 
    557564               IF (ln_salfix) THEN 
    558565                  ! Do not apply negative increments if the salinity will fall below a specified 
    559566                  ! 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) * zincwgt 
     567                  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 
    563570                  END WHERE 
    564571               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 
    566575               ENDIF 
    567576            END DO 
    … …  
    569578         ENDIF 
    570579         ! 
    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 
    574585         ENDIF 
    575586         !                             !-------------------------------------- 
    … …  
    584595            IF (ln_temnofreeze) THEN 
    585596               ! 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),:) 
    588599               END WHERE 
    589600            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 
    591604            ENDIF 
    592605            IF (ln_salfix) THEN 
    593606               ! Do not apply negative increments if the salinity will fall below a specified 
    594607               ! 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),:) 
    597610               END WHERE 
    598611            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 
    603620 
    604621            CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) )  ! Before potential and in situ densities 
    … …  
    607624!!gm 
    608625 
    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         ! 
    620648         ENDIF 
    621649         !   
    … …  
    829857      INTEGER, INTENT(in), OPTIONAL ::   kindic   ! flag for disabling the deallocation 
    830858      ! 
     859      INTEGER  ::   ji, jj 
    831860      INTEGER  ::   it 
    832861      REAL(wp) ::   zincwgt   ! IAU weight for current time step 
    833862#if defined key_si3 
    834       REAL(wp), DIMENSION(jpi,jpj) ::   zofrld, zohicif, zseaicendg, zhicifinc 
     863      REAL(wp), DIMENSION(A2D(nn_hls)) ::   zofrld, zohicif, zseaicendg, zhicifinc 
    835864      REAL(wp) ::   zhicifmin = 0.5_wp      ! ice minimum depth in metres 
    836865#endif 
    … …  
    847876            ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 
    848877            ! 
    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 
    853884            ENDIF 
    854885            ! 
    … …  
    856887            ! 
    857888#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 
    866899            ! 
    867900            ! 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(:,:)) * zincwgt     
     901            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 
     902               zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt 
    870903            ELSEWHERE 
    871904               zhicifinc(:,:) = 0.0_wp 
    … …  
    873906            ! 
    874907            ! 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 
    876911            ! 
    877912            ! seaice salinity balancing (to add) 
    … …  
    880915#if defined key_cice && defined key_asminc 
    881916            ! 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 
    887926            ENDIF 
    888927            ! 
    … …  
    890929            ! 
    891930#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 
    893934#endif 
    894935            ! 
    … …  
    905946            ! 
    906947#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 
    916959            ! 
    917960            ! 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)) 
    920963            ELSEWHERE 
    921964               zhicifinc(:,:) = 0.0_wp 
    … …  
    923966            ! 
    924967            ! 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 
    926971            ! 
    927972            ! seaice salinity balancing (to add) 
    … …  
    930975#if defined key_cice && defined key_asminc 
    931976            ! 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 
    937986            ! 
    938987         ELSE 
    939988            ! 
    940989#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 
    942993#endif 
    943994            ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/BDY/bdytra.F90

    r13527 r13992  
    1313   !!---------------------------------------------------------------------- 
    1414   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 
    1616   USE bdy_oce        ! ocean open boundary conditions 
    1717   USE bdylib         ! for orlanski library routines 
    … …  
    157157      INTEGER  ::   ib_bdy         ! Loop index 
    158158      !!---------------------------------------------------------------------- 
     159      IF( ntile /= 0 .AND. ntile /= 1 ) RETURN                        ! Do only for the full domain 
    159160      ! 
    160161      IF( ln_timing )   CALL timing_start('bdy_tra_dmp') 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DIA/diaar5.F90

    r13497 r13992  
    3434   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   thick0       ! ocean thickness (interior domain) 
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity 
     36   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   hstr_adv, hstr_ldf 
    3637 
    3738   LOGICAL  :: l_ar5 
    … …  
    5455      !!---------------------------------------------------------------------- 
    5556      ! 
    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 ) 
    5759      ! 
    5860      CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) 
    … …  
    304306   END SUBROUTINE dia_ar5 
    305307 
    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 ) 
    308310      !!---------------------------------------------------------------------- 
    309311      !!                    ***  ROUTINE dia_ar5_htr *** 
    … …  
    314316      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    315317      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf' 
    316       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: puflx  ! u-flux of advection/diffusion 
    317       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pvflx  ! v-flux of advection/diffusion 
     318      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 
    318320      ! 
    319321      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 
    322360     
    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_3D 
    327        CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 
    328        IF( cptr == 'adv' ) THEN 
    329           IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in i-direction 
    330           IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0     * z2d )  ! advective salt transport in i-direction 
    331        ENDIF 
    332        IF( cptr == 'ldf' ) THEN 
    333           IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction 
    334           IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0     * z2d ) ! diffusive salt transport in i-direction 
    335        ENDIF 
    336        ! 
    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_3D 
    341        CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 
    342        IF( cptr == 'adv' ) THEN 
    343           IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in j-direction 
    344           IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0     * z2d )  ! advective salt transport in j-direction 
    345        ENDIF 
    346        IF( cptr == 'ldf' ) THEN 
    347           IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction 
    348           IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0     * z2d ) ! diffusive salt transport in j-direction 
    349        ENDIF 
    350            
    351361   END SUBROUTINE dia_ar5_hst 
    352362 
    … …  
    371381         &  iom_use( 'masstot' ) .OR. iom_use( 'temptot'   )  .OR. iom_use( 'saltot' ) .OR.  &     
    372382         &  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. & 
    373387         &  iom_use( 'rhop' )  ) L_ar5 = .TRUE. 
    374388   

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DIA/diahsb.F90

    r13286 r13992  
    267267            IF(lwp) WRITE(numout,*) '   dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp 
    268268            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 ) 
    272272            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 ) 
    275275            ENDIF 
    276             CALL iom_get( numror, jpdom_auto, 'surf_ini'  , surf_ini  , ldxios = lrxios ) ! ice sheet coupling 
    277             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 ) 
    282282            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 ) 
    285285            ENDIF 
    286286         ELSE 
    … …  
    323323         IF(lwp) WRITE(numout,*) 
    324324         ! 
    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 ) 
    329328         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 ) 
    332331         ENDIF 
    333          CALL iom_rstput( kt, nitrst, numrow, 'surf_ini'  , surf_ini  , ldxios = lwxios )      ! ice sheet coupling 
    334          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 ) 
    339338         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 ) 
    342341         ENDIF 
    343          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    344342         ! 
    345343      ENDIF 
    … …  
    385383      IF( .NOT. ln_diahsb )   RETURN 
    386384 
    387       IF(lwxios) THEN 
    388 ! define variables in restart file when writing with XIOS 
    389         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 ) THEN 
    398            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         ENDIF 
    403       ENDIF 
    404385      ! ------------------- ! 
    405386      ! 1 - Allocate memory ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DIA/diaptr.F90

    r13557 r13992  
    2222   USE oce              ! ocean dynamics and active tracers 
    2323   USE dom_oce          ! ocean space and time domain 
     24   USE domain, ONLY : dom_tile 
    2425   USE phycst           ! physical constants 
    2526   ! 
    … …  
    3233   PRIVATE 
    3334 
     35   INTERFACE ptr_sum 
     36      MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 
     37   END INTERFACE 
     38 
    3439   INTERFACE ptr_sj 
    3540      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 
    … …  
    3944   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines 
    4045 
    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 
    4553 
    4654   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    5159   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 
    5260 
    53    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)   :: p_fval1d 
    54    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 
    55  
    5661   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag 
    57     
     62 
    5863   !! * Substitutions 
    5964#  include "do_loop_substitute.h90" 
    … …  
    7277      INTEGER                         , INTENT(in)           ::   kt     ! ocean time-step index      
    7378      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 
    75112      ! 
    76113      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    77       REAL(wp) ::   zsfc,zvfc               ! local scalar 
    78114      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
    79       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d    ! 3D workspace 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
    82115      REAL(wp), DIMENSION(jpj)      ::  zvsum, ztsum, zssum   ! 1D workspace 
    83116      ! 
    … …  
    90123      !!---------------------------------------------------------------------- 
    91124      ! 
    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 nbasin 
    95       ! 
    96       IF( .NOT. l_diaptr ) THEN 
    97          IF( ln_timing ) CALL timing_stop('dia_ptr') 
    98          RETURN 
    99       ENDIF 
    100       ! 
    101125      ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 
    102       ! 
     126 
    103127      IF( PRESENT( pvtr ) ) THEN 
    104128         IF( iom_use( 'zomsf' ) ) THEN    ! effective MSF 
    105129            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 
     130            ! 
    106131            DO jn = 1, nbasin                                    ! by sub-basins 
    107                z4d1(1,:,:,jn) =  ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  ! zonal cumulative effective transport excluding closed seas 
    108                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 
    109134                  z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn)    ! effective j-Stream-Function (MSF) 
    110135               END DO 
    111                DO ji = 1, jpi 
     136               DO ji = 2, jpi 
    112137                  z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 
    113138               ENDDO 
    114139            END DO 
    115140            CALL iom_put( 'zomsf', z4d1 * rc_sv ) 
     141            ! 
    116142            DEALLOCATE( z4d1 ) 
    117143         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 
    118375         IF(  iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.   & 
    119376            & 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 
    121381            zmask(:,:,:) = 0._wp 
    122382            zts(:,:,:,:) = 0._wp 
     383 
    123384            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    124385               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    125386               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  !Tracers averaged onto V grid 
     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 
    127388               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    128389            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 
    194403      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 
    200413            DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    201414               zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 
    … …  
    204417               zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 
    205418            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 
    292434         IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 
     435            ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 
     436 
    293437            zts(:,:,:,:) = 0._wp 
     438 
    294439            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    295440               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    297442               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    298443            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 
    323450      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 
    330452 
    331453 
    … …  
    340462      REAL(wp), DIMENSION(jpi,jpj) :: zmsk 
    341463      !!---------------------------------------------------------------------- 
    342        
     464 
    343465      ! l_diaptr is defined with iom_use 
    344466      !   --> dia_ptr_init must be done after the call to iom_init 
    … …  
    347469         &       iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  & 
    348470         &       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.  & 
    350472         &       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       
    353475      IF(lwp) THEN                     ! Control print 
    354476         WRITE(numout,*) 
    … …  
    398520         hstr_btr(:,:,:) = 0._wp           ! 
    399521         hstr_vtr(:,:,:) = 0._wp           ! 
     522         pvtr_int(:,:,:,:) = 0._wp 
     523         pzon_int(:,:,:,:) = 0._wp 
    400524         ! 
    401525         ll_init = .FALSE. 
    … …  
    415539      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    416540      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   ! 
    418543      INTEGER                                        :: jn    ! 
    419544 
     545      DO jn = 1, nbasin 
     546         zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
     547      ENDDO 
    420548      ! 
    421549      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(:,:) ) 
    432561      ENDIF 
    433562      ! 
    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 ) 
    445597      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 ) 
    458635      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 
    474638 
    475639 
    … …  
    479643      !!---------------------------------------------------------------------- 
    480644      INTEGER               ::   dia_ptr_alloc   ! return value 
    481       INTEGER, DIMENSION(3) ::   ierr 
     645      INTEGER, DIMENSION(2) ::   ierr 
    482646      !!---------------------------------------------------------------------- 
    483647      ierr(:) = 0 
    … …  
    491655            &      hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1)  ) 
    492656            ! 
    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) ) 
    494659         ! 
    495660         dia_ptr_alloc = MAXVAL( ierr ) 
    … …  
    511676      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    512677      !!---------------------------------------------------------------------- 
    513       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)  ::   pvflx  ! mask flux array at V-point 
    514       REAL(wp), INTENT(in), DIMENSION(jpi,jpj)      ::   pmsk   ! Optional 2D basin mask 
     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 
    515680      ! 
    516681      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 
    519683      !!-------------------------------------------------------------------- 
    520684      ! 
    521       p_fval => p_fval1d 
    522  
    523       ijpj = jpj 
    524685      p_fval(:) = 0._wp 
    525686      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    526687         p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    527688      END_3D 
    528 #if defined key_mpp_mpi 
    529       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) 
    530 #endif 
    531       ! 
    532689   END FUNCTION ptr_sj_3d 
    533690 
    … …  
    544701      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    545702      !!---------------------------------------------------------------------- 
    546       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pvflx  ! mask flux array at V-point 
     703      REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls))    ::   pvflx  ! mask flux array at V-point 
    547704      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pmsk   ! Optional 2D basin mask 
    548705      ! 
    549706      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 
    552708      !!-------------------------------------------------------------------- 
    553       !  
    554       p_fval => p_fval1d 
    555  
    556       ijpj = jpj 
     709      ! 
    557710      p_fval(:) = 0._wp 
    558711      DO_2D( 0, 0, 0, 0 ) 
    559712         p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 
    560713      END_2D 
    561 #if defined key_mpp_mpi 
    562       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) 
    563 #endif 
    564       !  
    565714   END FUNCTION ptr_sj_2d 
    566715 
    … …  
    588737            p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 
    589738         END_2D 
    590          CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 
    591739      END DO 
    592740      !  
    … …  
    607755      !! 
    608756      IMPLICIT none 
    609       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! mask flux array at V-point 
    610       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
     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 
    611759      !! 
    612760      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 
    620762      !!-------------------------------------------------------------------- 
    621763      ! 
    622       p_fval => p_fval2d 
    623  
    624764      p_fval(:,:) = 0._wp 
    625765      ! 
    … …  
    627767         p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    628768      END_3D 
    629       ! 
    630 #if defined key_mpp_mpi 
    631       ijpjjpk = jpj*jpk 
    632       ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    633       zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    634       CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl ) 
    635       p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    636 #endif 
    637       ! 
    638769   END FUNCTION ptr_sjk 
    639770 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/daymod.F90

    r13558 r13992  
    149149      CALL day( nit000 ) 
    150150      ! 
    151       IF( lwxios ) THEN 
    152 ! define variables in restart file when writing with XIOS 
    153           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       ENDIF 
    158  
    159151   END SUBROUTINE day_init 
    160152 
    … …  
    324316 
    325317      IF( TRIM(cdrw) == 'READ' ) THEN 
    326  
    327318         IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN 
    328319            ! Get Calendar informations 
    329             CALL iom_get( numror, 'kt', zkt, ldxios = lrxios )   ! last time-step of previous run 
     320            CALL iom_get( numror, 'kt', zkt )   ! last time-step of previous run 
    330321            IF(lwp) THEN 
    331322               WRITE(numout,*) ' *** Info read in restart : ' 
    … …  
    346337            IF ( nrstdt == 2 ) THEN 
    347338               ! 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 ) 
    349340               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  ) 
    352343               nn_time0 = NINT(ktime) 
    353344               ! calculate start time in hours and minutes 
    … …  
    410401         ENDIF 
    411402         ! 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 
    416406         !                                                                                                   ! 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 
    419408      ENDIF 
    420409      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/dom_oce.F90

    r13557 r13992  
    7474   LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity  
    7575 
     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 
    7686   !                             !: domain MPP decomposition parameters 
    7787   INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    … …  
    8797   INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    8898   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 
    89103   INTEGER, PUBLIC ::   nidom             !: ??? 
    90104 
    … …  
    296310      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
    297311         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
    298 #endif   
     312#endif 
    299313         ! 
    300314      ii = ii+1 
    301315      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) ) 
    303317         ! 
    304318      ii = ii+1 
    … …  
    317331         ! 
    318332      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)  ) 
    320334         ! 
    321335      ii = ii+1 
    … …  
    323337         ! 
    324338      ii = ii+1 
    325       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        &  
     339      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        & 
    326340         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
    327341         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
    … …  
    331345         ! 
    332346      ii = ii+1 
    333       ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     &  
     347      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
    334348         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
    335349         ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/domain.F90

    r13558 r13992  
    4545   USE closea , ONLY : dom_clo ! closed seas 
    4646   ! 
     47   USE prtctl         ! Print control (prt_ctl_info routine) 
    4748   USE in_out_manager ! I/O manager 
    4849   USE iom            ! I/O library 
    … …  
    5556   PUBLIC   dom_init     ! called by nemogcm.F90 
    5657   PUBLIC   domain_cfg   ! called by nemogcm.F90 
     58   PUBLIC   dom_tile     ! called by step.F90 
    5759 
    5860   !!------------------------------------------------------------------------- 
    … …  
    6365CONTAINS 
    6466 
    65    SUBROUTINE dom_init( Kbb, Kmm, Kaa, cdstr ) 
     67   SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 
    6668      !!---------------------------------------------------------------------- 
    6769      !!                  ***  ROUTINE dom_init  *** 
    … …  
    7981      !!---------------------------------------------------------------------- 
    8082      INTEGER          , INTENT(in) :: Kbb, Kmm, Kaa          ! ocean time level indices 
    81       CHARACTER (len=*), INTENT(in) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables 
    8283      ! 
    8384      INTEGER ::   ji, jj, jk, jt   ! dummy loop indices 
    … …  
    120121         WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
    121122      ENDIF 
     123      nn_wxios = 0 
     124      ln_xios_read = .FALSE. 
    122125      ! 
    123126      !           !==  Reference coordinate system  ==! 
    124127      ! 
    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 
    140132      ! 
    141133      CALL dom_hgr                      ! Horizontal mesh 
    … …  
    285277 
    286278 
     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 
    287362   SUBROUTINE dom_nam 
    288363      !!---------------------------------------------------------------------- 
    … …  
    293368      !! ** input   : - namrun namelist 
    294369      !!              - namdom namelist 
     370      !!              - namtile namelist 
    295371      !!              - namnc4 namelist   ! "key_netcdf4" only 
    296372      !!---------------------------------------------------------------------- 
    … …  
    305381         &             ln_cfmeta, ln_xios_read, nn_wxios 
    306382      NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 
     383      NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 
    307384#if defined key_netcdf4 
    308385      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
    … …  
    441518      r1_Dt = 1._wp / rDt 
    442519 
     520      READ  ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 
     521905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtile in reference namelist' ) 
     522      READ  ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) 
     523906   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 
    443540      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    444541         lrxios = ln_xios_read.AND.ln_rstart 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/domqco.F90

    r13295 r13992  
    9191      ! 
    9292      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 XIOS 
    95       !    CALL iom_set_rstw_var_active('e3t_b') 
    96       !    CALL iom_set_rstw_var_active('e3t_n') 
    97       ! ENDIF 
    9893      ! 
    9994   END SUBROUTINE dom_qco_init 
    … …  
    217212            ! 
    218213            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)    ) 
    221216               ! needed to restart if land processor not computed 
    222217               IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' 
    … …  
    232227               IF(lwp) write(numout,*) 'sshn set equal to sshb.' 
    233228               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) ) 
    235230               ssh(:,:,Kmm) = ssh(:,:,Kbb) 
    236231               l_1st_euler = .TRUE. 
    … …  
    239234               IF(lwp) write(numout,*) 'sshb set equal to sshn.' 
    240235               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) ) 
    242237               ssh(:,:,Kbb) = ssh(:,:,Kmm) 
    243238               l_1st_euler = .TRUE. 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/domutl.F90

    r13458 r13992  
    2121   PRIVATE 
    2222 
     23   INTERFACE is_tile 
     24      MODULE PROCEDURE is_tile_2d, is_tile_3d, is_tile_4d 
     25   END INTERFACE is_tile 
     26 
    2327   PUBLIC dom_ngb    ! routine called in iom.F90 module 
    2428   PUBLIC dom_uniq   ! Called by dommsk and domwri 
     29   PUBLIC is_tile 
    2530 
    2631   !!---------------------------------------------------------------------- 
    … …  
    109114      ! 
    110115   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 
    112156   !!====================================================================== 
    113157END MODULE domutl 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/domvvl.F90

    r13497 r13992  
    282282      ENDIF 
    283283      ! 
    284       IF(lwxios) THEN 
    285 ! define variables in restart file when writing with XIOS 
    286          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 IF 
    294          !                                           ! -------------!     
    295          IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    296             !                                        ! ------------ ! 
    297             CALL iom_set_rstw_var_active('hdiv_lf') 
    298          ENDIF 
    299          ! 
    300       ENDIF 
    301       ! 
    302284   END SUBROUTINE dom_vvl_zgr 
    303285 
    … …  
    440422         !                             (stored for tracer advction and continuity equation) 
    441423         CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
    442  
    443424         ! 4 - Time stepping of baroclinic scale factors 
    444425         ! --------------------------------------------- 
    … …  
    803784         IF( ln_rstart ) THEN                   !* Read the restart file 
    804785            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)    ) 
    806787            ! 
    807788            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    816797            ! 
    817798            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) ) 
    820801               ! needed to restart if land processor not computed  
    821802               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    831812               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    832813               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) ) 
    834815               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    835816               l_1st_euler = .true. 
    … …  
    838819               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    839820               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) ) 
    841822               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    842823               l_1st_euler = .true. 
    … …  
    863844               !                          ! ----------------------- ! 
    864845               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(:,:,:) ) 
    867848               ELSE                            ! one at least array is missing 
    868849                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    873854                  !                       ! ------------ ! 
    874855                  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(:,:,:) ) 
    876857                  ELSE                ! array is missing 
    877858                     hdiv_lf(:,:,:) = 0.0_wp 
    … …  
    946927         !                                   ! =================== 
    947928         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    948          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    949929         !                                           ! --------- ! 
    950930         !                                           ! all cases ! 
    951931         !                                           ! --------- ! 
    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) ) 
    954934         !                                           ! ----------------------- ! 
    955935         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    956936            !                                        ! ----------------------- ! 
    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(:,:,:)) 
    959939         END IF 
    960940         !                                           ! -------------!     
    961941         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    962942            !                                        ! ------------ ! 
    963             CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) 
     943            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 
    964944         ENDIF 
    965945         ! 
    966          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    967946      ENDIF 
    968947      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DOM/dtatsd.F90

    r13497 r13992  
    1818   USE phycst          ! physical constants 
    1919   USE dom_oce         ! ocean space and time domain 
     20   USE domain, ONLY : dom_tile 
    2021   USE fldread         ! read input fields 
    2122   ! 
    … …  
    135136      !! ** Action  :   ptsd   T-S data on medl mesh and interpolated at time-step kt 
    136137      !!---------------------------------------------------------------------- 
    137       INTEGER                              , INTENT(in   ) ::   kt     ! ocean time-step 
    138       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
     138      INTEGER                          , INTENT(in   ) ::   kt     ! ocean time-step 
     139      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
    139140      ! 
    140141      INTEGER ::   ji, jj, jk, jl, jkk   ! dummy loop indicies 
    141142      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers 
     143      INTEGER ::   itile 
    142144      REAL(wp)::   zl, zi                             ! local scalars 
    143145      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace 
    144146      !!---------------------------------------------------------------------- 
    145147      ! 
    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   ==! 
    147152      ! 
    148153      ! 
    149154!!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 
    167173               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 
    176181!!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 
    180189      ! 
    181190      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    182191         ! 
    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 
    189201            DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    190202               zl = gdept_0(ji,jj,jk) 
    … …  
    215227      ELSE                                !==   z- or zps- coordinate   ==! 
    216228         !                              
    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 
    219233         ! 
    220234         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 ) 
    222237               ik = mbkt(ji,jj)  
    223238               IF( ik > 1 ) THEN 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DYN/dynhpg.F90

    r13295 r13992  
    302302      INTEGER  ::   iku, ikv                         ! temporary integers 
    303303      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 
    306307      !!---------------------------------------------------------------------- 
    307308      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/DYN/dynspg_ts.F90

    r13546 r13992  
    900900         !                                   ! --------------- 
    901901         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 )  
    906906            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 ) 
    913913            ENDIF 
    914914#if defined key_agrif 
    915915            ! Read time integrated fluxes 
    916916            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 ) 
    919919            ELSE 
    920920               ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    … …  
    935935         !                                   ! ------------------- 
    936936         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  (:,:) ) 
    942941         ! 
    943942         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(:,:) ) 
    950949         ENDIF 
    951950#if defined key_agrif 
    952951         ! Save time integrated fluxes 
    953952         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(:,:) ) 
    956955         ENDIF 
    957956#endif 
    958          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    959957      ENDIF 
    960958      ! 
    … …  
    10481046      !                             ! read restart when needed 
    10491047      CALL ts_rst( nit000, 'READ' ) 
    1050       ! 
    1051       IF( lwxios ) THEN 
    1052 ! define variables in restart file when writing with XIOS 
    1053          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) THEN 
    1059             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          ENDIF 
    1066 #if defined key_agrif 
    1067          ! Save time integrated fluxes 
    1068          IF ( .NOT.Agrif_Root() ) THEN 
    1069             CALL iom_set_rstw_var_active('ub2_i_b') 
    1070             CALL iom_set_rstw_var_active('vb2_i_b') 
    1071          ENDIF 
    1072 #endif 
    1073       ENDIF 
    10741048      ! 
    10751049   END SUBROUTINE dyn_spg_ts_init 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/in_out_manager.F90

    r13286 r13992  
    8989   LOGICAL ::   lrst_abl              !: logical to control the abl restart write  
    9090   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 
    96101   INTEGER ::   nrst_lst              !: number of restart to output next 
    97102 
    … …  
    165170   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T 
    166171   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 
    170184 
    171185   !! * Substitutions 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/iom.F90

    r13747 r13992  
    4646   USE lib_fortran  
    4747   USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal 
     48   USE iom_nf90 
     49   USE netcdf 
    4850 
    4951   IMPLICIT NONE 
    … …  
    5860   PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 
    5961   PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 
     62   PUBLIC iom_xios_setid 
    6063 
    6164   PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 
    … …  
    6972   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 
    7073   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_active 
     74   PRIVATE iom_set_rst_context, iom_set_vars_active 
    7275# 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 
    7478 
    7579   INTERFACE iom_get 
    … …  
    101105CONTAINS 
    102106 
    103    SUBROUTINE iom_init( cdname, fname, ld_closedef )  
     107   SUBROUTINE iom_init( cdname, kdid, ld_closedef )  
    104108      !!---------------------------------------------------------------------- 
    105109      !!                     ***  ROUTINE   *** 
    … …  
    109113      !!---------------------------------------------------------------------- 
    110114      CHARACTER(len=*),           INTENT(in)  :: cdname 
    111       CHARACTER(len=*), OPTIONAL, INTENT(in)  :: fname 
     115      INTEGER         , OPTIONAL, INTENT(in)  :: kdid           
    112116      LOGICAL         , OPTIONAL, INTENT(in)  :: ld_closedef 
    113117#if defined key_iomput 
    … …  
    118122      INTEGER             :: irefyear, irefmonth, irefday 
    119123      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 
    121127      ! 
    122128      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 
    123129      REAL(wp), DIMENSION(2,jpkam1)         :: za_bnds   ! ABL vertical boundaries 
    124       LOGICAL ::   ll_closedef = .TRUE. 
     130      LOGICAL ::   ll_closedef 
    125131      LOGICAL ::   ll_exist 
    126132      !!---------------------------------------------------------------------- 
    127133      ! 
     134      ll_closedef = .TRUE. 
    128135      IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 
    129136      ! 
    … …  
    134141      CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) 
    135142      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 
    137153 
    138154      ! Calendar type is now defined in xml file  
    … …  
    153169      IF(.NOT.llrst_context) CALL set_scalar 
    154170      ! 
    155       IF( TRIM(cdname) == TRIM(cxios_context) ) THEN   
     171      IF( cdname == cxios_context ) THEN   
    156172         CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. )  
    157173         CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) 
    … …  
    197213      ! vertical grid definition 
    198214      IF(.NOT.llrst_context) THEN 
    199           CALL iom_set_axis_attr(  "deptht", paxis = gdept_1d ) 
    200           CALL iom_set_axis_attr(  "depthu", paxis = gdept_1d ) 
    201           CALL iom_set_axis_attr(  "depthv", paxis = gdept_1d ) 
    202           CALL iom_set_axis_attr(  "depthw", paxis = gdepw_1d ) 
     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 ) 
    203219 
    204220          ! ABL 
    205           IF( .NOT. ALLOCATED(ght_abl) ) THEN   ! force definition for xml files (xios)  
    206              ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) )   ! default allocation needed by iom 
    207              ght_abl(:) = -1._wp   ;   ghw_abl(:) = -1._wp 
    208              e3t_abl(:) = -1._wp   ;   e3w_abl(:) = -1._wp 
    209           ENDIF 
    210           CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 
    211           CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 
     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) ) 
    212228           
    213           ! Add vertical grid bounds 
    214           zt_bnds(2,:      ) = gdept_1d(:) 
    215           zt_bnds(1,2:jpk  ) = gdept_1d(1:jpkm1) 
    216           zt_bnds(1,1      ) = gdept_1d(1) - e3w_1d(1) 
    217           zw_bnds(1,:      ) = gdepw_1d(:) 
    218           zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
    219           zw_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
    220           CALL iom_set_axis_attr(  "deptht", bounds=zw_bnds ) 
    221           CALL iom_set_axis_attr(  "depthu", bounds=zw_bnds ) 
    222           CALL iom_set_axis_attr(  "depthv", bounds=zw_bnds ) 
    223           CALL iom_set_axis_attr(  "depthw", bounds=zt_bnds ) 
    224  
    225           ! ABL 
    226           za_bnds(1,:) = ghw_abl(1:jpkam1) 
    227           za_bnds(2,:) = ghw_abl(2:jpka  ) 
    228           CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 
    229           za_bnds(1,:) = ght_abl(2:jpka  ) 
    230           za_bnds(2,:) = ght_abl(2:jpka  ) + e3w_abl(2:jpka) 
    231           CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 
    232  
    233           CALL iom_set_axis_attr(  "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
     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) /) ) 
    234250# if defined key_si3 
    235           CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    236           ! SIMIP diagnostics (4 main arctic straits) 
    237           CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 
     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) /) ) 
    238254# endif 
    239255#if defined key_top 
    240           IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 
    241 #endif 
    242           CALL iom_set_axis_attr( "icbcla", class_num ) 
    243           CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) )   ! strange syntaxe and idea... 
    244           CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) )   ! strange syntaxe and idea... 
    245           CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
    246           ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 
    247           INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 
    248           nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 
    249           CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 
     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) /) ) 
    250266      ENDIF 
    251267      ! 
    252268      ! 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) 
    265279      ELSE 
    266           CALL set_xmlatt 
     280         CALL set_xmlatt 
    267281      ENDIF 
    268282      ! 
    … …  
    280294   END SUBROUTINE iom_init 
    281295 
    282    SUBROUTINE iom_init_closedef 
     296   SUBROUTINE iom_init_closedef(cdname) 
    283297      !!---------------------------------------------------------------------- 
    284298      !!            ***  SUBROUTINE iom_init_closedef  *** 
    … …  
    288302      !! 
    289303      !!---------------------------------------------------------------------- 
    290  
     304      CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname 
    291305#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 
    294324#else 
    295325      IF( .FALSE. )   WRITE(numout,*) 'iom_init_closedef: should not see this'   ! useless statement to avoid compilation warnings 
    … …  
    298328   END SUBROUTINE iom_init_closedef 
    299329 
    300    SUBROUTINE iom_set_rstw_var_active(field) 
     330   SUBROUTINE iom_set_vars_active(idnum) 
    301331      !!--------------------------------------------------------------------- 
    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. 
    305337      !!--------------------------------------------------------------------- 
    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       
    311340#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) 
    334440      !!--------------------------------------------------------------------- 
    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 
    339444      !!--------------------------------------------------------------------- 
    340  
    341 !sets enabled = .TRUE. for each field in restart file 
    342    CHARACTER(len=256) :: rst_file 
    343  
     445      CHARACTER(len=*) :: cdrst_file 
    344446#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 
    358450!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) 
    548469      !!--------------------------------------------------------------------- 
    549470      !!                   ***  SUBROUTINE iom_set_rstw_active   *** 
    … …  
    553474      !!--------------------------------------------------------------------- 
    554475!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 
    556485#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) 
    577490!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 
    597528#endif 
    598529   END SUBROUTINE iom_set_rstw_active 
    599530 
     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 
    600580   SUBROUTINE iom_set_rst_context(ld_rstr)  
    601      !!--------------------------------------------------------------------- 
     581      !!--------------------------------------------------------------------- 
    602582      !!                   ***  SUBROUTINE  iom_set_rst_context  *** 
    603583      !! 
    … …  
    606586      !!                
    607587      !!--------------------------------------------------------------------- 
    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 
    611590#if defined key_iomput 
    612    TYPE(xios_domaingroup)            :: domaingroup_hdl  
    613    TYPE(xios_domain)                 :: domain_hdl  
    614    TYPE(xios_axisgroup)              :: axisgroup_hdl  
    615    TYPE(xios_axis)                   :: axis_hdl  
    616    TYPE(xios_scalar)                 :: scalar_hdl  
    617    TYPE(xios_scalargroup)            :: scalargroup_hdl  
    618  
    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)  
    622601  
    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")  
    625604!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")  
    632614#endif 
    633615   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 
    634655 
    635656   SUBROUTINE iom_swap( cdname ) 
    … …  
    642663#if defined key_iomput 
    643664      TYPE(xios_context) :: nemo_hdl 
    644  
    645665      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    646666        CALL xios_get_handle(TRIM(cdname),nemo_hdl) 
    … …  
    892912   !!                   INTERFACE iom_get 
    893913   !!---------------------------------------------------------------------- 
    894    SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 
     914   SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) 
    895915      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
    896916      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
    … …  
    898918      REAL(dp)                                        ::   ztmp_pvar ! tmp var to read field 
    899919      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
    900       LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
    901920      ! 
    902921      INTEGER                                         ::   idvar     ! variable id 
    … …  
    906925      CHARACTER(LEN=100)                              ::   clname    ! file name 
    907926      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 
    914932         itime = 1 
    915933         IF( PRESENT(ktime) ) itime = ktime 
    … …  
    934952#if defined key_iomput 
    935953         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 
    936          CALL iom_swap( TRIM(crxios_context) ) 
     954         CALL iom_swap(context) 
    937955         CALL xios_recv_field( trim(cdvar), pvar) 
    938          CALL iom_swap( TRIM(cxios_context) ) 
     956         CALL iom_swap(cxios_context) 
    939957#else 
    940958         WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 
    … …  
    944962   END SUBROUTINE iom_g0d_sp 
    945963 
    946    SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 
     964   SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) 
    947965      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
    948966      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
    949967      REAL(dp)        , INTENT(  out)                 ::   pvar      ! read field 
    950968      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
    951       LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
    952969      ! 
    953970      INTEGER                                         ::   idvar     ! variable id 
    … …  
    957974      CHARACTER(LEN=100)                              ::   clname    ! file name 
    958975      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 
    965981         itime = 1 
    966982         IF( PRESENT(ktime) ) itime = ktime 
    … …  
    9841000#if defined key_iomput 
    9851001         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 
    986          CALL iom_swap( TRIM(crxios_context) ) 
     1002         CALL iom_swap(context) 
    9871003         CALL xios_recv_field( trim(cdvar), pvar) 
    988          CALL iom_swap( TRIM(cxios_context) ) 
     1004         CALL iom_swap(cxios_context) 
    9891005#else 
    9901006         WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 
    … …  
    9941010   END SUBROUTINE iom_g0d_dp 
    9951011 
    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 ) 
    9971013      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    9981014      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10031019      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
    10041020      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis 
    1005       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10061021      ! 
    10071022      IF( kiomid > 0 ) THEN 
    … …  
    10091024            ALLOCATE(ztmp_pvar(size(pvar,1))) 
    10101025            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 ) 
    10131027            pvar = ztmp_pvar 
    10141028            DEALLOCATE(ztmp_pvar) 
    … …  
    10181032 
    10191033 
    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 ) 
    10211035      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10221036      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10261040      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
    10271041      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis 
    1028       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10291042      ! 
    10301043      IF( kiomid > 0 ) THEN 
    10311044         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) 
    10341046      ENDIF 
    10351047   END SUBROUTINE iom_g1d_dp 
    10361048 
    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) 
    10381050      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10391051      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10471059      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kstart    ! start axis position of the reading  
    10481060      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kcount    ! number of points in each axis 
    1049       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10501061      ! 
    10511062      IF( kiomid > 0 ) THEN 
    … …  
    10541065            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r2d = ztmp_pvar  , ktime = ktime,   & 
    10551066             &                                                      cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1056              &                                                      kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1067             &                                                      kstart  = kstart , kcount = kcount  ) 
    10571068            pvar = ztmp_pvar 
    10581069            DEALLOCATE(ztmp_pvar) 
    … …  
    10611072   END SUBROUTINE iom_g2d_sp 
    10621073 
    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) 
    10641075      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10651076      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10721083      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kstart    ! start axis position of the reading  
    10731084      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kcount    ! number of points in each axis 
    1074       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10751085      ! 
    10761086      IF( kiomid > 0 ) THEN 
    10771087         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r2d = pvar  , ktime = ktime,   & 
    10781088            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1079             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1089            &                                                       kstart  = kstart , kcount = kcount                ) 
    10801090      ENDIF 
    10811091   END SUBROUTINE iom_g2d_dp 
    10821092 
    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 ) 
    10841094      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10851095      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10931103      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kstart    ! start axis position of the reading  
    10941104      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kcount    ! number of points in each axis 
    1095       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10961105      ! 
    10971106      IF( kiomid > 0 ) THEN 
    … …  
    11001109            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r3d = ztmp_pvar  , ktime = ktime,   & 
    11011110            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1102             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1111            &                                                       kstart  = kstart , kcount = kcount                ) 
    11031112            pvar = ztmp_pvar 
    11041113            DEALLOCATE(ztmp_pvar) 
    … …  
    11071116   END SUBROUTINE iom_g3d_sp 
    11081117 
    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 ) 
    11101119      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    11111120      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    11181127      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kstart    ! start axis position of the reading  
    11191128      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kcount    ! number of points in each axis 
    1120       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    11211129      ! 
    11221130      IF( kiomid > 0 ) THEN 
    … …  
    11241132            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r3d = pvar  , ktime = ktime,   & 
    11251133            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1126             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1134            &                                                       kstart  = kstart , kcount = kcount                ) 
    11271135         END IF 
    11281136      ENDIF 
    … …  
    11321140 
    11331141   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 ) 
    11351143      !!----------------------------------------------------------------------- 
    11361144      !!                  ***  ROUTINE  iom_get_123d  *** 
    … …  
    11521160      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart    ! start position of the reading in each axis  
    11531161      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 restart 
    11551162      ! 
    11561163      LOGICAL                        ::   llok        ! true if ok! 
    1157       LOGICAL                        ::   llxios      ! local definition for XIOS read 
    11581164      INTEGER                        ::   jl          ! loop on number of dimension  
    11591165      INTEGER                        ::   idom        ! type of domain 
    … …  
    11821188      REAL(dp)                       ::   gma, gmi 
    11831189      !--------------------------------------------------------------------- 
    1184       ! 
     1190      CHARACTER(LEN=lc)                               ::   context 
     1191      ! 
     1192      CALL set_xios_context(kiomid, context) 
    11851193      inlev = -1 
    11861194      IF( PRESENT(pv_r3d) )   inlev = SIZE(pv_r3d, 3) 
    11871195      ! 
    1188       llxios = .FALSE. 
    1189       IF( PRESENT(ldxios) )   llxios = ldxios 
    1190       ! 
    11911196      idom = kdom 
    11921197      istop = nstop 
    11931198      ! 
    1194       IF(.NOT.llxios) THEN 
     1199      IF(context == "NONE") THEN 
    11951200         clname = iom_file(kiomid)%name   !   esier to read 
    11961201         clinfo = '          iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) 
    … …  
    13591364#if defined key_iomput 
    13601365!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 
    13621373         IF( PRESENT(pv_r3d) ) THEN 
    13631374            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 
    13661379         ELSEIF( PRESENT(pv_r2d) ) THEN 
    13671380            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 
    13701385         ELSEIF( PRESENT(pv_r1d) ) THEN 
    13711386            IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 
    13721387            CALL xios_recv_field( trim(cdvar), pv_r1d) 
    13731388         ENDIF 
    1374          CALL iom_swap( TRIM(cxios_context) ) 
     1389         CALL iom_swap(cxios_context) 
    13751390#else 
    13761391         istop = istop + 1  
    … …  
    13871402      zofs = iom_file(kiomid)%ofs(idvar)      ! offset 
    13881403      IF(     PRESENT(pv_r1d) ) THEN 
    1389          IF( zscf /= 1. )   pv_r1d(:) = pv_r1d(:) * zscf  
    1390          IF( zofs /= 0. )   pv_r1d(:) = pv_r1d(:) + zofs 
     1404         IF( zscf /= 1._wp )   pv_r1d(:) = pv_r1d(:) * zscf  
     1405         IF( zofs /= 0._wp )   pv_r1d(:) = pv_r1d(:) + zofs 
    13911406      ELSEIF( PRESENT(pv_r2d) ) THEN 
    1392          IF( zscf /= 1.)   pv_r2d(:,:) = pv_r2d(:,:) * zscf 
    1393          IF( zofs /= 0.)   pv_r2d(:,:) = pv_r2d(:,:) + zofs 
     1407         IF( zscf /= 1._wp)   pv_r2d(:,:) = pv_r2d(:,:) * zscf 
     1408         IF( zofs /= 0._wp)   pv_r2d(:,:) = pv_r2d(:,:) + zofs 
    13941409      ELSEIF( PRESENT(pv_r3d) ) THEN 
    1395          IF( zscf /= 1.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 
    1396          IF( zofs /= 0.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 
     1410         IF( zscf /= 1._wp)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 
     1411         IF( zofs /= 0._wp)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 
    13971412      ENDIF 
    13981413      ! 
    … …  
    15681583   !!                   INTERFACE iom_rstput 
    15691584   !!---------------------------------------------------------------------- 
    1570    SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1585   SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    15711586      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15721587      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    15751590      REAL(sp)        , INTENT(in)                         ::   pvar     ! written field 
    15761591      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 
    15831601      IF( llx ) THEN 
    15841602#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 
    15891614#endif 
    15901615      ELSE 
    … …  
    15981623   END SUBROUTINE iom_rp0d_sp 
    15991624 
    1600    SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1625   SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16011626      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16021627      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16051630      REAL(dp)        , INTENT(in)                         ::   pvar     ! written field 
    16061631      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 
    16131641      IF( llx ) THEN 
    16141642#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 
    16191654#endif 
    16201655      ELSE 
    … …  
    16291664 
    16301665 
    1631    SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1666   SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16321667      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16331668      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16361671      REAL(sp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    16371672      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 
    16441682      IF( llx ) THEN 
    16451683#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 
    16501695#endif 
    16511696      ELSE 
    … …  
    16591704   END SUBROUTINE iom_rp1d_sp 
    16601705 
    1661    SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1706   SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16621707      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16631708      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16661711      REAL(dp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    16671712      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 
    16741722      IF( llx ) THEN 
    16751723#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 
    16801735#endif 
    16811736      ELSE 
    … …  
    16901745 
    16911746 
    1692    SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1747   SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16931748      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16941749      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16971752      REAL(sp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    16981753      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 
    17051763      IF( llx ) THEN 
    17061764#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 
    17111776#endif 
    17121777      ELSE 
    … …  
    17201785   END SUBROUTINE iom_rp2d_sp 
    17211786 
    1722    SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1787   SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17231788      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17241789      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17271792      REAL(dp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    17281793      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 
    17351803      IF( llx ) THEN 
    17361804#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 
    17411816#endif 
    17421817      ELSE 
    … …  
    17511826 
    17521827 
    1753    SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1828   SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17541829      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17551830      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17581833      REAL(sp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    17591834      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 
    17661844      IF( llx ) THEN 
    17671845#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 
    17721857#endif 
    17731858      ELSE 
    … …  
    17811866   END SUBROUTINE iom_rp3d_sp 
    17821867 
    1783    SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1868   SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17841869      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17851870      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17881873      REAL(dp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    17891874      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 
    17961884      IF( llx ) THEN 
    17971885#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 
    18021897#endif 
    18031898      ELSE 
    … …  
    18651960      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    18661961      REAL(sp)        , INTENT(in) ::   pfield0d 
    1867 !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1962      !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    18681963#if defined key_iomput 
    18691964!!clem      zz(:,:)=pfield0d 
    … …  
    21452240      CALL iom_swap( cdname )   ! swap to cdname context 
    21462241      CALL xios_update_calendar(kt) 
    2147       IF( cdname /= TRIM(cxios_context) )   CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
     2242      IF( cdname /= TRIM(cxios_context) )   CALL iom_swap( cxios_context )   ! return back to nemo context 
    21482243   END SUBROUTINE iom_setkt 
    21492244 
    … …  
    21592254         CALL iom_swap( cdname )   ! swap to cdname context 
    21602255         CALL xios_context_finalize() ! finalize the context 
    2161          IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
     2256         IF( cdname /= cxios_context ) CALL iom_swap( cxios_context )   ! return back to nemo context 
    21622257      ENDIF 
    21632258      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/iom_def.F90

    r13558 r13992  
    99   !!---------------------------------------------------------------------- 
    1010   USE par_kind 
     11   USE netcdf 
    1112 
    1213   IMPLICIT NONE 
    … …  
    3637   INTEGER, PUBLIC            ::   nxioso = 0          !: type of restart file when writing using XIOS 1 - single, 2 - multiple 
    3738!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 
    3940   LOGICAL, PUBLIC            ::   lxios_sini = .FALSE. ! is restart in a single file 
    40    LOGICAL, PUBLIC            ::   lxios_set  = .FALSE.  
     41 
     42 
    4143 
    4244   TYPE, PUBLIC ::   file_descriptor 
    … …  
    5961   END TYPE file_descriptor 
    6062   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_vars 
    62    TYPE, PUBLIC :: RST_FIELD   
    63     CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file 
    64     CHARACTER(len=30) :: grid = "NO_GRID" 
    65     LOGICAL           :: active =.FALSE. ! for restart write only: true - write field, false do not write field 
    66    END TYPE RST_FIELD 
    6763!$AGRIF_END_DO_NOT_TREAT 
    68    ! 
    69    TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields) 
    7064   ! 
    7165   !! * Substitutions 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/iom_nf90.F90

    r13286 r13992  
    3131   PUBLIC iom_nf90_open  , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput 
    3232   PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt 
     33   PUBLIC iom_nf90_check 
    3334 
    3435   INTERFACE iom_nf90_get 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/prtctl.F90

    r13286 r13992  
    88   !!---------------------------------------------------------------------- 
    99   USE dom_oce          ! ocean space and time domain variables 
     10   USE domutl, ONLY : is_tile 
    1011   USE in_out_manager   ! I/O manager 
    1112   USE mppini           ! distributed memory computing 
    … …  
    2627   PUBLIC prt_ctl_init    ! called by nemogcm.F90 and prt_ctl_trc_init 
    2728 
     29   !! * Substitutions 
     30#  include "do_loop_substitute.h90" 
    2831   !!---------------------------------------------------------------------- 
    2932   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3538   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2,   & 
    3639      &                 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 ) 
    3769      !!---------------------------------------------------------------------- 
    3870      !!                     ***  ROUTINE prt_ctl  *** 
    … …  
    70102      !!                    clinfo3 : additional information  
    71103      !!---------------------------------------------------------------------- 
    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 
    77110      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask1 
    78111      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask2 
    … …  
    106139 
    107140         ! 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 ) 
    112145 
    113146         IF( PRESENT(clinfo) ) THEN   ;   inum = numprt_top(jl) 
    … …  
    115148         ENDIF 
    116149 
    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 
    128223               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 
    193229      END DO 
    194230      ! 
    195    END SUBROUTINE prt_ctl 
     231   END SUBROUTINE prt_ctl_t 
    196232 
    197233 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/IOM/restart.F90

    r13286 r13992  
    110110            ELSE 
    111111#if defined key_iomput 
    112                cwxios_context = "rstw_"//TRIM(ADJUSTL(clkt)) 
     112               cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) 
    113113               IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    114114                  clpname = clname 
    … …  
    116116                  clpname = TRIM(Agrif_CFixed())//"_"//clname    
    117117               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. ) 
    120120               CALL iom_swap(      cxios_context          ) 
    121121#else 
    … …  
    143143      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    144144      !!---------------------------------------------------------------------- 
    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 
    148147 
    149148      IF ( .NOT. ln_diurnal_only ) THEN 
    150                      CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb), ldxios = lwxios        )     ! before fields 
    151                      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)) 
    155154                     ! 
    156                      CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm), ldxios = lwxios        )     ! now fields 
    157                      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      ) 
    162161      ENDIF 
    163162       
    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 )   
    166164      IF( kt == nitrst ) THEN 
    167165         IF(.NOT.lwxios) THEN 
    168166            CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    169167         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 
    171171         ENDIF 
    172172!!gm         IF( .NOT. lk_trdmld )   lrst_oce = .FALSE. 
    … …  
    191191      !!                the file has already been opened 
    192192      !!---------------------------------------------------------------------- 
    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 
    195196      !!---------------------------------------------------------------------- 
    196197      ! 
    … …  
    209210! can handle checking if variable is in the restart file (there will be no need to open 
    210211! restart) 
    211          IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini 
     212         lrxios = lrxios.AND.lxios_sini 
     213 
    212214         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 
    225226      ENDIF 
    226227 
    … …  
    246247      ! Check dynamics and tracer time-step consistency and force Euler restart if changed 
    247248      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 ) 
    249250         IF( zrdt /= rn_Dt ) THEN 
    250251            IF(lwp) WRITE( numout,*) 
    … …  
    256257      ENDIF 
    257258 
    258       CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
     259      IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
    259260       
    260261      ! 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 )  
    262263      IF ( ln_diurnal_only ) THEN  
    263264         IF(lwp) WRITE( numout, * ) & 
    264265         &   "rst_read:- ln_diurnal_only set, setting rhop=rho0"  
    265266         rhop = rho0 
    266          CALL iom_get( numror, jpdom_auto, 'tn'     , w3d, ldxios = lrxios )  
     267         CALL iom_get( numror, jpdom_auto, 'tn'     , w3d )  
    267268         ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) 
    268269         RETURN  
    269270      ENDIF   
    270        
     271 
    271272      IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 
    272273         ! 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) ) 
    278279      ELSE 
    279280         l_1st_euler =  .TRUE.      ! before field not found, forced euler 1st time-step 
    … …  
    281282      ! 
    282283      ! 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) ) 
    288289      IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
    289          CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop, ldxios = lrxios )   ! now    potential density 
     290         CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop )   ! now    potential density 
    290291      ELSE 
    291292         CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) )    

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ISF/isfcav.F90

    r13226 r13992  
    183183      ! cavity mask 
    184184      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 
    188191      !================ 
    189192      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ISF/isfcpl.F90

    r13295 r13992  
    120120      e3t(:,:,:,Kbb)   = e3t(:,:,:,Kmm) 
    121121#endif  
    122       ! prepare writing restart 
    123       IF( lwxios ) THEN 
    124          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 IF 
    130       ! 
    131122   END SUBROUTINE isfcpl_init 
    132123   !  
    … …  
    153144      END DO  
    154145      ! 
    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 ) 
    163152      ! 
    164153   END SUBROUTINE isfcpl_rst_write 
    … …  
    183172      !!---------------------------------------------------------------------- 
    184173      ! 
    185       CALL iom_get( numror, jpdom_auto, 'ssmask'  , zssmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
     174      CALL iom_get( numror, jpdom_auto, 'ssmask'  , zssmask_b   ) ! need to extrapolate T/S 
    186175 
    187176      ! compute new ssh if we open a full water column  
    … …  
    264253      !!---------------------------------------------------------------------- 
    265254      !  
    266       CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
    267       !CALL iom_get( numror, jpdom_auto, 'wmask'  , zwmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
    268       !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) 
    269258      ! 
    270259      !  
    … …  
    410399      !!---------------------------------------------------------------------- 
    411400      ! 
    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  ) 
    415404      ! 
    416405      ! 1.0: compute horizontal volume flux divergence difference before-after coupling 
    … …  
    520509 
    521510      ! get restart variable 
    522       CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b(:,:,:), ldxios = lrxios  ) ! need to extrapolate T/S 
    523       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(:,:,:)    ) 
    526515 
    527516      ! compute run length 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ISF/isfrst.F90

    r13286 r13992  
    5353      IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 
    5454         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 melt 
    56          CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios )   ! before ice shelf heat flux 
    57          CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios )   ! before ice shelf heat flux 
     55         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 
    5858      ELSE 
    5959         pfwf_b(:,:)   = pfwf(:,:) 
    … …  
    6161      ENDIF 
    6262      ! 
    63       IF( lwxios ) THEN 
    64          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       ENDIF 
    68  
    6963   END SUBROUTINE isfrst_read 
    7064   !  
    … …  
    9589      ! 
    9690      ! 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) ) 
    10294      ! 
    10395   END SUBROUTINE isfrst_write 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r13472 r13992  
    4040      &                    , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12  & 
    4141      &                    , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16  & 
    42       &                    , kfillmode, pfillval, lsend, lrecv ) 
     42      &                    , kfillmode, pfillval, lsend, lrecv, ncsten ) 
    4343      !!--------------------------------------------------------------------- 
    4444      CHARACTER(len=*)     ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
    … …  
    5555      REAL(wp)             , OPTIONAL        , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    5656      LOGICAL, DIMENSION(4), OPTIONAL        , INTENT(in   ) ::   lsend, lrecv   ! indicate how communications are to be carried out 
     57      LOGICAL              , OPTIONAL        , INTENT(in   ) ::   ncsten 
    5758      !! 
    5859      INTEGER                          ::   kfld        ! number of elements that will be attributed 
    … …  
    8485      IF( PRESENT(psgn16) )   CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    8586      ! 
    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 ) 
    8788      ! 
    8889   END SUBROUTINE ROUTINE_MULTI 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LBC/lbclnk.F90

    r13226 r13992  
    3939      MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    4040   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 
    4149   ! 
    4250   INTERFACE lbc_lnk_icb 
    … …  
    5260   END INTERFACE 
    5361 
    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) 
    5767 
    5868#if   defined key_mpp_mpi 
    … …  
    250260#  undef DIM_4d 
    251261 
     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 
    252404 
    253405   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LBC/lib_mpp.F90

    r13636 r13992  
    6666   PUBLIC   mppscatter, mppgather 
    6767   PUBLIC   mpp_ini_znl 
     68   PUBLIC   mpp_ini_nc 
    6869   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    6970   PUBLIC   mppsend_sp, mpprecv_sp                          ! needed by TAM and ICB routines 
    … …  
    137138   INTEGER         ::   ndim_rank_znl   !  number of processors on the same zonal average 
    138139   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) 
    139144 
    140145   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 
    … …  
    10671072 
    10681073   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 
    10691221 
    10701222 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LBC/mpp_lnk_generic.h90

    r13286 r13992  
    7272 
    7373#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 ) 
    7575      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    7676#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 ) 
    7878#endif 
    7979      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    … …  
    8484      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    8585      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 
    8687      ! 
    8788      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices 
    … …  
    100101      !!---------------------------------------------------------------------- 
    101102      ! 
     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 
    102111      ! ----------------------------------------- ! 
    103112      !     0. local variables initialization     ! 
    … …  
    387396      IF( llrecv_no )   DEALLOCATE( zrcv_no ) 
    388397      ! 
     398#endif 
    389399   END SUBROUTINE ROUTINE_LNK 
    390400#undef PRECISION 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LBC/mppini.F90

    r13490 r13992  
    542542      ij = ijn(narea) 
    543543      ! 
    544       ! set default neighbours 
    545       noso = ii_noso(narea) 
    546       nowe = ii_nowe(narea) 
    547       noea = ii_noea(narea) 
    548       nono = ii_nono(narea) 
    549544      jpi    = ijpi(ii,ij)   
    550545!!$      Nis0  = iis0(ii,ij) 
    … …  
    558553      njmpp = ijmppt(ii,ij) 
    559554      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 
    560614      ! 
    561615      CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls)  
    … …  
    648702         ENDIF 
    649703      ENDIF 
     704 
     705      ! 
     706      CALL mpp_ini_nc        ! Initialize communicator for neighbourhood collective communications 
    650707      ! 
    651708      CALL init_ioipsl       ! Prepare NetCDF output file (if necessary) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LDF/ldfc1d_c2d.F90

    r13497 r13992  
    140140         END_2D 
    141141      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 ) 
    143144            pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn 
    144145            pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/LDF/ldftra.F90

    r13558 r13992  
    427427         zaht_min = 0.2_wp * aht0                                       ! minimum value for aht 
    428428         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 ) 
    430431            !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) 
    431432            !!     ==>>>   The Coriolis value is identical for t- & u_points, and for v- and f-points 
    … …  
    725726      !! ** Action  : pu, pv increased by the eiv transport 
    726727      !!---------------------------------------------------------------------- 
    727       INTEGER                         , INTENT(in   ) ::   kt        ! ocean time-step index 
    728       INTEGER                         , INTENT(in   ) ::   kit000    ! first time step index 
    729       INTEGER                         , INTENT(in   ) ::   Kmm, Krhs ! ocean time level indices 
    730       CHARACTER(len=3)                , INTENT(in   ) ::   cdtype    ! =TRA or TRC (tracer indicator) 
    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] 
    734735      !! 
    735736      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    736737      REAL(wp) ::   zuwk, zuwk1, zuwi, zuwi1   ! local scalars 
    737738      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 
    745748      ENDIF 
    746749 
    … …  
    781784      !! 
    782785      !!---------------------------------------------------------------------- 
    783       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   psi_uw, psi_vw   ! streamfunction   [m3/s] 
    784       INTEGER                         , INTENT(in   ) ::   Kmm   ! ocean time level indices 
     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 
    785788      ! 
    786789      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    787790      REAL(wp) ::   zztmp   ! local scalar 
    788       REAL(wp), DIMENSION(jpi,jpj)     ::   zw2d   ! 2D workspace 
    789       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d   ! 3D workspace 
     791      REAL(wp), DIMENSION(A2D(nn_hls))     ::   zw2d   ! 2D workspace 
     792      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zw3d   ! 3D workspace 
    790793      !!---------------------------------------------------------------------- 
    791794      ! 
    … …  
    793796!!gm     to be redesigned....    
    794797      !                                                  !==  eiv stream function: output  ==! 
    795       CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp ) 
    796       ! 
    797798!!gm      CALL iom_put( "psi_eiv_uw", psi_uw )                 ! output 
    798799!!gm      CALL iom_put( "psi_eiv_vw", psi_vw ) 
    … …  
    802803      zw3d(:,:,jpk) = 0._wp                                    ! bottom value always 0 
    803804      ! 
    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 DO 
     805      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 
    807808      CALL iom_put( "uoce_eiv", zw3d ) 
    808809      ! 
    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 DO 
     810      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 
    812813      CALL iom_put( "voce_eiv", zw3d ) 
    813814      ! 
    … …  
    816817            &              + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj  ,jk)  ) / e1e2t(ji,jj) 
    817818      END_3D 
    818       CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp )      ! lateral boundary condition 
    819819      CALL iom_put( "woce_eiv", zw3d ) 
    820820      ! 
    821821      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 
    823825         DO jk = 1, jpk 
    824826            zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) 
    … …  
    844846           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    845847        END_3D 
    846         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
    847         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    848848        CALL iom_put( "ueiv_heattr"  , zztmp * zw2d )                  ! heat transport in i-direction 
    849849        CALL iom_put( "ueiv_heattr3d", zztmp * zw3d )                  ! heat transport in i-direction 
    … …  
    865865         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    866866      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 
    870869      ! 
    871870      IF( iom_use( 'sophteiv' ) )   CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) 
    … …  
    880879           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    881880        END_3D 
    882         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
    883         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    884881        CALL iom_put( "ueiv_salttr", zztmp * zw2d )                  ! salt transport in i-direction 
    885882        CALL iom_put( "ueiv_salttr3d", zztmp * zw3d )                ! salt transport in i-direction 
    … …  
    892889         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    893890      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 
    897893      ! 
    898894      IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/SBC/sbcapr.F90

    r13286 r13992  
    6565      CHARACTER(len=100) ::  cn_dir   ! Root directory for location of ssr files 
    6666      TYPE(FLD_N)        ::  sn_apr   ! informations about the fields to be read 
    67       LOGICAL            ::  lrxios   ! read restart using XIOS? 
    6867      !! 
    6968      NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc 
    … …  
    108107            CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 
    109108      ! 
    110       IF( lwxios ) THEN 
    111          CALL iom_set_rstw_var_active('ssh_ibb') 
    112       ENDIF 
    113109   END SUBROUTINE sbc_apr_init 
    114110 
    … …  
    154150         IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN  
    155151            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 ssh 
     152            CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb )   ! before inv. barometer ssh 
    157153            ! 
    158154         ELSE                                         !* no restart: set from nit000 values 
    … …  
    167163         IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp 
    168164         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 ) 
    172166      ENDIF 
    173167      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/SBC/sbcflx.F90

    r13497 r13992  
    127127 
    128128         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) 
    130130         ELSE 
    131131            DO_2D( 0, 0, 0, 0 ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/SBC/sbcmod.F90

    r13722 r13992  
    359359      IF( ln_wave     )   CALL sbc_wave_init                     ! surface wave initialisation 
    360360      ! 
    361       IF( lwxios ) THEN 
    362          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 traqsr 
    366          ! 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       ENDIF 
    370  
    371361   END SUBROUTINE sbc_init 
    372362 
    … …  
    510500            & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 
    511501            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) 
    515505            ! 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) 
    518508            ! To ensure restart capability with 3.3x/3.4 restart files    !! to be removed in v3.6 
    519509            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) 
    521511            ELSE 
    522512               sfx_b (:,:) = sfx(:,:) 
    … …  
    538528            &                    'at it= ', kt,' date= ', ndastp 
    539529         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  ) 
    544533         ! The 3D heat content due to qsr forcing is treated in traqsr 
    545534         ! 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  ) 
    549537      ENDIF 
    550538      !                                                ! ---------------------------------------- ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/SBC/sbcrnf.F90

    r13497 r13992  
    160160            & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 
    161161            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 runoff 
    163             CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios )   ! before heat content of runoff 
    164             CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! before salinity content of runoff 
     162            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 
    165165         ELSE                                                   !* no restart: set from nit000 values 
    166166            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    … …  
    176176            &                    'at it= ', kt,' date= ', ndastp 
    177177         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) ) 
    183181      ENDIF 
    184182      ! 
    … …  
    480478      ENDIF 
    481479      ! 
    482       IF( lwxios ) THEN 
    483          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       ENDIF 
    487  
    488480   END SUBROUTINE sbc_rnf_init 
    489481 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/SBC/sbcssm.F90

    r13286 r13992  
    154154            IF(lwp) WRITE(numout,*) '~~~~~~~' 
    155155            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            ! 
    167165         ENDIF 
    168166         ! 
    … …  
    208206         IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN 
    209207            l_ssm_mean = .TRUE. 
    210             CALL iom_get( numror            , 'nn_fsbc', zf_sbc,ldxios = lrxios )     ! sbc frequency of previous run 
    211             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) 
    217215            ! fraction of solar net radiation absorbed in 1st T level 
    218216            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  ) 
    220218            ELSE 
    221219               frq_m(:,:) = 1._wp   ! default definition 
    … …  
    255253      IF( .NOT. ln_traqsr )   fraqsr_1lev(:,:) = 1._wp   ! default definition: qsr 100% in the fisrt level  
    256254      ! 
    257       IF( lwxios.AND.nn_fsbc > 1 ) THEN 
    258          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       ENDIF 
    267  
    268255   END SUBROUTINE sbc_ssm_init 
    269256 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/eosbn2.F90

    r13955 r13992  
    3939   !!---------------------------------------------------------------------- 
    4040   USE dom_oce        ! ocean space and time domain 
     41   USE domutl, ONLY : is_tile 
    4142   USE phycst         ! physical constants 
    4243   USE stopar         ! Stochastic T/S fluctuations 
    … …  
    189190 
    190191   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 ) 
    191202      !!---------------------------------------------------------------------- 
    192203      !!                   ***  ROUTINE eos_insitu  *** 
    … …  
    222233      !!                TEOS-10 Manual, 2010 
    223234      !!---------------------------------------------------------------------- 
    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] 
    228240      ! 
    229241      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    238250      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    239251         ! 
    240          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     252         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    241253            ! 
    242254            zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    … …  
    274286      CASE( np_seos )                !==  simplified EOS  ==! 
    275287         ! 
    276          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     288         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    277289            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    278290            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    … …  
    293305      IF( ln_timing )   CALL timing_stop('eos-insitu') 
    294306      ! 
    295    END SUBROUTINE eos_insitu 
     307   END SUBROUTINE eos_insitu_t 
    296308 
    297309 
    298310   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 ) 
    299323      !!---------------------------------------------------------------------- 
    300324      !!                  ***  ROUTINE eos_insitu_pot  *** 
    … …  
    309333      !! 
    310334      !!---------------------------------------------------------------------- 
    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] 
    316341      ! 
    317342      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    … …  
    338363            END DO 
    339364            ! 
    340             DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     365            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    341366               ! 
    342367               ! compute density (2*nn_sto_eos) times: 
    … …  
    388413         ! Non-stochastic equation of state 
    389414         ELSE 
    390             DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     415            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    391416               ! 
    392417               zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    … …  
    426451      CASE( np_seos )                !==  simplified EOS  ==! 
    427452         ! 
    428          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     453         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    429454            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    430455            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    … …  
    444469      END SELECT 
    445470      ! 
    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 ) 
    447473      ! 
    448474      IF( ln_timing )   CALL timing_stop('eos-pot') 
    449475      ! 
    450    END SUBROUTINE eos_insitu_pot 
     476   END SUBROUTINE eos_insitu_pot_t 
    451477 
    452478 
    453479   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 ) 
    454491      !!---------------------------------------------------------------------- 
    455492      !!                  ***  ROUTINE eos_insitu_2d  *** 
    … …  
    462499      !! 
    463500      !!---------------------------------------------------------------------- 
    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 
    468506      ! 
    469507      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    480518      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    481519         ! 
    482          DO_2D( 1, 1, 1, 1 ) 
     520         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    483521            ! 
    484522            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    … …  
    515553      CASE( np_seos )                !==  simplified EOS  ==! 
    516554         ! 
    517          DO_2D( 1, 1, 1, 1 ) 
     555         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    518556            ! 
    519557            zt    = pts  (ji,jj,jp_tem)  - 10._wp 
    … …  
    535573      IF( ln_timing )   CALL timing_stop('eos2d') 
    536574      ! 
    537    END SUBROUTINE eos_insitu_2d 
     575   END SUBROUTINE eos_insitu_2d_t 
    538576 
    539577 
    … …  
    612650 
    613651   SUBROUTINE rab_3d( pts, pab, Kmm ) 
     652      !! 
     653      INTEGER                     , INTENT(in   ) ::   Kmm   ! time level index 
     654      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     655      REAL(wp), DIMENSION(:,:,:,:), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     656      !! 
     657      CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 
     658   END SUBROUTINE rab_3d 
     659 
     660 
     661   SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 
    614662      !!---------------------------------------------------------------------- 
    615663      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    621669      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    622670      !!---------------------------------------------------------------------- 
    623       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    624       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
    625       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     671      INTEGER                                , INTENT(in   ) ::   Kmm   ! time level index 
     672      INTEGER                                , INTENT(in   ) ::   ktts, ktab 
     673      REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     674      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    626675      ! 
    627676      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    636685      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    637686         ! 
    638          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     687         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    639688            ! 
    640689            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
    … …  
    689738      CASE( np_seos )                  !==  simplified EOS  ==! 
    690739         ! 
    691          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     740         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    692741            zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    693742            zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    … …  
    714763      IF( ln_timing )   CALL timing_stop('rab_3d') 
    715764      ! 
    716    END SUBROUTINE rab_3d 
     765   END SUBROUTINE rab_3d_t 
    717766 
    718767 
    719768   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
     769      !! 
     770      INTEGER                   , INTENT(in   ) ::   Kmm   ! time level index 
     771      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     772      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep   ! depth                  [m] 
     773      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     774      !! 
     775      CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 
     776   END SUBROUTINE rab_2d 
     777 
     778 
     779   SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 
    720780      !!---------------------------------------------------------------------- 
    721781      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    725785      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    726786      !!---------------------------------------------------------------------- 
    727       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    728       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    729       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
    730       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     787      INTEGER                            , INTENT(in   ) ::   Kmm   ! time level index 
     788      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktab 
     789      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     790      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep   ! depth                  [m] 
     791      REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
    731792      ! 
    732793      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    743804      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    744805         ! 
    745          DO_2D( 1, 1, 1, 1 ) 
     806         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    746807            ! 
    747808            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    … …  
    796857      CASE( np_seos )                  !==  simplified EOS  ==! 
    797858         ! 
    798          DO_2D( 1, 1, 1, 1 ) 
     859         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    799860            ! 
    800861            zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    … …  
    821882      IF( ln_timing )   CALL timing_stop('rab_2d') 
    822883      ! 
    823    END SUBROUTINE rab_2d 
     884   END SUBROUTINE rab_2d_t 
    824885 
    825886 
    … …  
    922983 
    923984   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
     985      !! 
     986      INTEGER                              , INTENT(in   ) ::  Kmm   ! time level index 
     987      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     988      REAL(wp), DIMENSION(:,:,:,:)         , INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     989      REAL(wp), DIMENSION(:,:,:)           , INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     990      !! 
     991      CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 
     992   END SUBROUTINE bn2 
     993 
     994 
     995   SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 
    924996      !!---------------------------------------------------------------------- 
    925997      !!                  ***  ROUTINE bn2  *** 
    … …  
    9351007      !! 
    9361008      !!---------------------------------------------------------------------- 
    937       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    938       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
    939       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
    940       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     1009      INTEGER                                , INTENT(in   ) ::  Kmm   ! time level index 
     1010      INTEGER                                , INTENT(in   ) ::  ktab, ktn2 
     1011      REAL(wp), DIMENSION(jpi,jpj,  jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     1012      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1013      REAL(wp), DIMENSION(A2D_T(ktn2),JPK     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    9411014      ! 
    9421015      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    9461019      IF( ln_timing )   CALL timing_start('bn2') 
    9471020      ! 
    948       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.F90 
     1021      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 
    9491022         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    9501023            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
    … …  
    9621035      IF( ln_timing )   CALL timing_stop('bn2') 
    9631036      ! 
    964    END SUBROUTINE bn2 
     1037   END SUBROUTINE bn2_t 
    9651038 
    9661039 
    … …  
    10221095 
    10231096 
    1024    SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     1097   SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 
     1098      !! 
     1099      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1100      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1101      REAL(wp), DIMENSION(:,:)    , INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1102      !! 
     1103      CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 
     1104   END SUBROUTINE eos_fzp_2d 
     1105 
     1106 
     1107   SUBROUTINE  eos_fzp_2d_t( psal, ptf, kttf, pdep ) 
    10251108      !!---------------------------------------------------------------------- 
    10261109      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10341117      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10351118      !!---------------------------------------------------------------------- 
    1036       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    1037       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1038       REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1119      INTEGER                       , INTENT(in   )           ::   kttf 
     1120      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   )           ::   psal   ! salinity   [psu] 
     1121      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1122      REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
    10391123      ! 
    10401124      INTEGER  ::   ji, jj          ! dummy loop indices 
    … …  
    10691153      END SELECT       
    10701154      ! 
    1071   END SUBROUTINE eos_fzp_2d 
     1155  END SUBROUTINE eos_fzp_2d_t 
    10721156 
    10731157 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv.F90

    r13237 r13992  
    1818   USE oce            ! ocean dynamics and active tracers 
    1919   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 
    2022   USE domvvl         ! variable vertical scale factors 
    2123   USE sbcwave        ! wave module 
    … …  
    2325   USE traadv_cen     ! centered scheme            (tra_adv_cen  routine) 
    2426   USE traadv_fct     ! FCT      scheme            (tra_adv_fct  routine) 
     27   USE traadv_fct_lf  ! FCT      scheme            (tra_adv_fct  routine - loop fusion version) 
    2528   USE traadv_mus     ! MUSCL    scheme            (tra_adv_mus  routine) 
     29   USE traadv_mus_lf  ! MUSCL    scheme            (tra_adv_mus  routine - loop fusion version) 
    2630   USE traadv_ubs     ! UBS      scheme            (tra_adv_ubs  routine) 
    2731   USE traadv_qck     ! QUICKEST scheme            (tra_adv_qck  routine) 
    … …  
    6569   INTEGER, PARAMETER ::   np_UBS     = 4   ! 3rd order Upstream Biased Scheme 
    6670   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme 
    67     
     71 
     72   !! * Substitutions 
     73#  include "do_loop_substitute.h90" 
    6874#  include "domzgr_substitute.h90" 
    6975   !!---------------------------------------------------------------------- 
    … …  
    8692      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts            ! active tracers and RHS of tracer equation 
    8793      ! 
    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 
    91100      !!---------------------------------------------------------------------- 
    92101      ! 
    93102      IF( ln_timing )   CALL timing_start('tra_adv') 
    94103      ! 
    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 
    168232      ENDIF 
    169233      !                                              ! 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, & 
    171235         &                                  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 
    172241      ! 
    173242      IF( ln_timing )   CALL timing_stop( 'tra_adv' ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv_cen.F90

    r13497 r13992  
    7171      INTEGER                                  , INTENT(in   ) ::   kn_cen_h        ! =2/4 (2nd or 4th order scheme) 
    7272      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) 
    7374      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    7475      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    7879      REAL(wp) ::   zC2t_u, zC4t_u   ! local scalars 
    7980      REAL(wp) ::   zC2t_v, zC4t_v   !   -      - 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zwy, zwz, ztu, ztv, ztw 
     81      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwx, zwy, zwz, ztu, ztv, ztw 
    8182      !!---------------------------------------------------------------------- 
    8283      ! 
    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. 
    8798      ENDIF 
    88       !                          ! set local switches 
    89       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. 
    9699      ! 
    97100      !                     
    … …  
    112115            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero 
    113116            ztv(:,:,jpk) = 0._wp 
    114             DO_3D( 0, 0, 0, 0, 1, jpkm1 )          ! masked gradient 
     117            DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )          ! masked gradient 
    115118               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    116119               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    117120            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. 
    119122            ! 
    120             DO_3D( 0, 0, 0, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
     123            DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
    121124               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
    122125               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    … …  
    128131               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
    129132            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. ) 
    131134            ! 
    132135         CASE DEFAULT 
    … …  
    155158               END_2D 
    156159            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 
    158163            ENDIF 
    159164         ENDIF 
    … …  
    171176            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 
    172177            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    173          END IF 
    174          !                                 ! "Poleward" heat and salt transports  
     178         ENDIF 
     179         !                                 ! "Poleward" heat and salt transports 
    175180         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    176181         !                                 !  heat and salt transport 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv_fct.F90

    r13497 r13992  
    3434   PUBLIC   tra_adv_fct        ! called by traadv.F90 
    3535   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 
    3638 
    3739   LOGICAL  ::   l_trd   ! flag to compute trends 
    … …  
    7981      INTEGER                                  , INTENT(in   ) ::   kn_fct_v        ! order of the FCT scheme (=2 or 4) 
    8082      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 
    8185      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    8286      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    8387      ! 
    84       INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices   
     88      INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices 
    8589      REAL(wp) ::   ztra                                     ! local scalar 
    8690      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u   !   -      - 
    8791      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, ztw 
     92      REAL(wp), DIMENSION(A2D(nn_hls),jpk)        ::   zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 
    8993      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdx, ztrdy, ztrdz, zptry 
    9094      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwinf, zwdia, zwsup 
    … …  
    9296      !!---------------------------------------------------------------------- 
    9397      ! 
    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         ! 
    98115      ENDIF 
     116 
    99117      !! -- init to 0 
    100118      zwi(:,:,:) = 0._wp 
    … …  
    108126      ztw(:,:,:) = 0._wp 
    109127      ! 
    110       l_trd = .FALSE.            ! set local switches 
    111       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       ! 
    119128      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) ) 
    121130         ztrdx(:,:,:) = 0._wp   ;    ztrdy(:,:,:) = 0._wp   ;   ztrdz(:,:,:) = 0._wp 
    122131      ENDIF 
    123132      ! 
    124       IF( l_ptr ) THEN   
    125          ALLOCATE( zptry(jpi,jpj,jpk) ) 
     133      IF( l_ptr ) THEN 
     134         ALLOCATE( zptry(A2D(nn_hls),jpk) ) 
    126135         zptry(:,:,:) = 0._wp 
    127136      ENDIF 
    128       !                          ! surface & bottom value : flux set to zero one for all 
    129       zwz(:,:, 1 ) = 0._wp             
    130       zwx(:,:,jpk) = 0._wp   ;   zwy(:,:,jpk) = 0._wp    ;    zwz(:,:,jpk) = 0._wp 
    131       ! 
    132       zwi(:,:,:) = 0._wp         
    133137      ! 
    134138      ! If adaptive vertical advection, check if it is needed on this PE at this time 
    135139      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. 
    137141      END IF 
    138142      ! If active adaptive vertical advection, build tridiagonal matrix 
    139143      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 ) 
    142146            zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) )   & 
    143147            &                               / e3t(ji,jj,jk,Krhs) 
    … …  
    151155         !        !==  upstream advection with initial mass fluxes & intermediate update  ==! 
    152156         !                    !* 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 ) 
    154158            ! upstream scheme 
    155159            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) 
    … …  
    178182         ENDIF 
    179183         !                
    180          DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* trend and after field with monotonic scheme 
     184         DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )   !* trend and after field with monotonic scheme 
    181185            !                               ! total intermediate advective trends 
    182186            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    … …  
    194198            ! 
    195199            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) 
    197201               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    198202               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    206210            ! 
    207211         END IF 
    208          !                 
     212         ! 
    209213         IF( l_trd .OR. l_hst )  THEN             ! trend diagnostics (contribution of upstream fluxes) 
    210214            ztrdx(:,:,:) = zwx(:,:,:)   ;   ztrdy(:,:,:) = zwy(:,:,:)   ;   ztrdz(:,:,:) = zwz(:,:,:) 
    … …  
    218222         ! 
    219223         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 ) 
    221225               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) 
    222226               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) 
    … …  
    238242            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    239243            ! 
    240             DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
     244            DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    241245               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 
    242246               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 
    244248               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) 
    245249               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) 
    246250            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) 
    247252            ! 
    248253         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    249254            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    250255            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) 
    252257               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    253258               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    254259            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) 
    256263            ! 
    257264            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    … …  
    265272               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    266273            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) 
    267275            ! 
    268276         END SELECT 
    … …  
    271279         ! 
    272280         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 ) 
    274282               zwz(ji,jj,jk) =  (  pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
    275283                  &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
    … …  
    278286         CASE(  4  )                   !- 4th order COMPACT 
    279287            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 ) 
    281289               zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
    282290            END_3D 
    … …  
    286294            zwz(:,:,1) = 0._wp   ! only ocean surface as interior zwz values have been w-masked 
    287295         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         ! 
    289309         IF ( ll_zAimp ) THEN 
    290             DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !* trend and after field with monotonic scheme 
     310            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )    !* trend and after field with monotonic scheme 
    291311               !                                                ! total intermediate advective trends 
    292312               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    293313                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    294314                  &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    295                ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     315               ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
    296316            END_3D 
    297317            ! 
    298318            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    299319            ! 
    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) 
    301321               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    302322               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    303                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) 
     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) 
    304324            END_3D 
    305325         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 ) 
    308326         ! 
    309327         !        !==  monotonicity algorithm  ==! 
    … …  
    334352                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    335353            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 
    338357         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 
    340359            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  !     to upstream fluxes 
    341360            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! 
    … …  
    350369            ! 
    351370         ENDIF 
     371         ! NOTE: [tiling-comms-merge] I tested this 
     372         ! NOT TESTED - NEED l_ptr TRUE 
    352373         IF( l_ptr ) THEN              ! "Poleward" transports 
    353374            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< add anti-diffusive fluxes 
    … …  
    360381         DEALLOCATE( zwdia, zwinf, zwsup ) 
    361382      ENDIF 
    362       IF( l_trd .OR. l_hst ) THEN  
     383      IF( l_trd .OR. l_hst ) THEN 
    363384         DEALLOCATE( ztrdx, ztrdy, ztrdz ) 
    364385      ENDIF 
    … …  
    383404      !!       in-space based differencing for fluid 
    384405      !!---------------------------------------------------------------------- 
    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 
    389411      ! 
    390412      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    392414      REAL(dp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
    393415      REAL(dp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    394       REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
     416      REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo 
    395417      !!---------------------------------------------------------------------- 
    396418      ! 
    … …  
    402424      ! -------------------- 
    403425      ! 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 
    408432 
    409433      DO jk = 1, jpkm1 
    410434         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 ) 
    412436 
    413437            ! search maximum in neighbourhood 
    … …  
    439463         END_2D 
    440464      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) 
    442466 
    443467      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    444468      ! ---------------------------------------- 
    445       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     469      DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    446470         zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    447471         zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    … …  
    461485         pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    462486      END_3D 
    463       CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp )   ! lateral boundary condition (changed sign) 
    464487      ! 
    465488   END SUBROUTINE nonosc 
    … …  
    537560      !!---------------------------------------------------------------------- 
    538561      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-point 
     562      REAL(wp),DIMENSION(A2D(nn_hls)    ,jpk), INTENT(  out) ::   pt_out   ! field interpolated at w-point 
    540563      ! 
    541564      INTEGER ::   ji, jj, jk   ! dummy loop integers 
    542565      INTEGER ::   ikt, ikb     ! local integers 
    543       REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt 
     566      REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt 
    544567      !!---------------------------------------------------------------------- 
    545568      ! 
    546569      !                      !==  build the three diagonal matrix & the RHS  ==! 
    547570      ! 
    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) 
    549572         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    550573         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    … …  
    565588      END IF 
    566589      ! 
    567       DO_2D( 0, 0, 0, 0 )              ! 2nd order centered at top & bottom 
     590      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )              ! 2nd order centered at top & bottom 
    568591         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    569592         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    … …  
    582605      !                       !==  tridiagonal solver  ==! 
    583606      ! 
    584       DO_2D( 0, 0, 0, 0 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
     607      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    585608         zwt(ji,jj,2) = zwd(ji,jj,2) 
    586609      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 ) 
    588611         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    589612      END_3D 
    590613      ! 
    591       DO_2D( 0, 0, 0, 0 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
     614      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    592615         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    593616      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 ) 
    595618         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    596619      END_3D 
    597620 
    598       DO_2D( 0, 0, 0, 0 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
     621      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    599622         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    600623      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 ) 
    602625         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    603626      END_3D 
    … …  
    626649      !!        The 3d array zwt is used as a work space array. 
    627650      !!---------------------------------------------------------------------- 
    628       REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pD, pU, PL    ! 3-diagonal matrix 
    629       REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pRHS          ! Right-Hand-Side 
    630       REAL(wp),DIMENSION(:,:,:), INTENT(  out) ::   pt_out        !!gm field at level=F(klev) 
    631       INTEGER                  , INTENT(in   ) ::   klev          ! =1 pt_out at w-level  
    632       !                                                           ! =0 pt at t-level 
     651      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 
    633656      INTEGER ::   ji, jj, jk   ! dummy loop integers 
    634657      INTEGER ::   kstart       ! local indices 
    635       REAL(wp),DIMENSION(jpi,jpj,jpk) ::   zwt   ! 3D work array 
     658      REAL(wp),DIMENSION(A2D(nn_hls),jpk) ::   zwt   ! 3D work array 
    636659      !!---------------------------------------------------------------------- 
    637660      ! 
    638661      kstart =  1  + klev 
    639662      ! 
    640       DO_2D( 0, 0, 0, 0 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
     663      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    641664         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    642665      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 ) 
    644667         zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    645668      END_3D 
    646669      ! 
    647       DO_2D( 0, 0, 0, 0 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
     670      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    648671         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    649672      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 ) 
    651674         pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    652675      END_3D 
    653676 
    654       DO_2D( 0, 0, 0, 0 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
     677      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    655678         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    656679      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 ) 
    658681         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    659682      END_3D 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv_mus.F90

    r13497 r13992  
    8181      LOGICAL                                  , INTENT(in   ) ::   ld_msc_ups      ! use upstream scheme within muscl 
    8282      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     83      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    8384      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    8485      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    8889      REAL(wp) ::   zu, z0u, zzwx, zw , zalpha   ! local scalars 
    8990      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      - 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace 
    91       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   ! -      - 
    9293      !!---------------------------------------------------------------------- 
    9394      ! 
    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 
    126129      ! 
    127130      DO jn = 1, kjpt            !==  loop over the tracers  ==! 
    … …  
    132135         zwx(:,:,jpk) = 0._wp                   ! bottom values 
    133136         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 ) 
    135138            zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    136139            zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    137140         END_3D 
    138141         ! 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 ) 
    140143         !                                !-- Slopes of tracer 
    141144         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    142145         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 ) 
    144147            zslpx(ji,jj,jk) =                       ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    145148               &            * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    … …  
    148151         END_3D 
    149152         ! 
    150          DO_3D( 0, 1, 0, 1, 1, jpkm1 )    !-- Slopes limitation 
     153         DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 )    !-- Slopes limitation 
    151154            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    152155               &                                                     2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    … …  
    157160         END_3D 
    158161         ! 
    159          DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- MUSCL horizontal advective fluxes 
     162         DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 )    !-- MUSCL horizontal advective fluxes 
    160163            ! MUSCL fluxes 
    161164            z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) 
    … …  
    173176            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    174177         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) 
    176179         ! 
    177180         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- Tracer advective trend 
    … …  
    195198         zwx(:,:, 1 ) = 0._wp                   ! surface & bottom boundary conditions 
    196199         zwx(:,:,jpk) = 0._wp 
    197          DO jk = 2, jpkm1                       ! interior values 
    198             zwx(:,:,jk) = tmask(:,:,jk) * ( pt(:,:,jk-1,jn,Kbb) - pt(:,:,jk,jn,Kbb) ) 
    199          END DO 
     200         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 
    200203         !                                !-- Slopes of tracer 
    201204         zslpx(:,:,1) = 0._wp                   ! surface values 
    … …  
    223226               END_2D 
    224227            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 
    226231            ENDIF 
    227232         ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv_qck.F90

    r13497 r13992  
    9191      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
    9292      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 
    9395      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
    9496      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    9597      !!---------------------------------------------------------------------- 
    9698      ! 
    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. 
    102111      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       ! 
    109112      ! 
    110113      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    … …  
    127130      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
    128131      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     132      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    129133      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU        ! i-velocity components 
    130134      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    … …  
    132136      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    133137      REAL(wp) ::   ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
    134       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zfu, zfc, zfd 
     138      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwx, zfu, zfc, zfd 
    135139      !---------------------------------------------------------------------- 
    136140      ! 
    … …  
    142146         ! 
    143147!!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 mask 
     148         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 
    145149            zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
    146150            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    147151         END_3D 
    148          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions  
     152         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
    149153          
    150154         ! 
    151155         ! Horizontal advective fluxes 
    152156         ! --------------------------- 
    153          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     157         DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 
    154158            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    155159            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    156160         END_3D 
    157161         ! 
    158          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     162         DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 
    159163            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    160164            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    … …  
    164168         END_3D 
    165169         !--- 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 ) 
    167171 
    168172         !--- QUICKEST scheme 
    … …  
    170174         ! 
    171175         ! 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 ) 
    173177            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    174178         END_3D 
    175          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )      ! Lateral boundary conditions  
     179         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )      ! Lateral boundary conditions 
    176180 
    177181         ! 
    178182         ! 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 
    192191         ! 
    193192         ! Computation of the trend 
    … …  
    216215      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
    217216      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     217      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    218218      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pV        ! j-velocity components 
    219219      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    … …  
    221221      INTEGER  :: ji, jj, jk, jn                ! dummy loop indices 
    222222      REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
    223       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zfu, zfc, zfd   ! 3D workspace 
     223      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwy, zfu, zfc, zfd   ! 3D workspace 
    224224      !---------------------------------------------------------------------- 
    225225      ! 
    … …  
    233233            !                                              
    234234            !--- 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 ) 
    236236               ! Upstream in the x-direction for the tracer 
    237237               zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) 
    … …  
    240240            END_2D 
    241241         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 
    244243          
    245244         ! 
    … …  
    247246         ! --------------------------- 
    248247         ! 
    249          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     248         DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 
    250249            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    251250            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    252251         END_3D 
    253252         ! 
    254          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     253         DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 
    255254            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    256255            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    261260 
    262261         !--- 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 ) 
    264263 
    265264         !--- QUICKEST scheme 
    … …  
    267266         ! 
    268267         ! 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 ) 
    270269            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    271270         END_3D 
    272          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )    !--- Lateral boundary conditions  
     271         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )    !--- Lateral boundary conditions 
    273272         ! 
    274273         ! 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 
    288282         ! 
    289283         ! Computation of the trend 
    … …  
    313307      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    314308      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 
    316311      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    317312      ! 
    318313      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    319       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz   ! 3D workspace 
     314      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwz   ! 3D workspace 
    320315      !!---------------------------------------------------------------------- 
    321316      ! 
    … …  
    332327         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask) 
    333328            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 ) 
    335330                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
    336331               END_2D 
    337332            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 
    339336            ENDIF 
    340337         ENDIF 
    … …  
    359356      !! ** Method :    
    360357      !!---------------------------------------------------------------------- 
    361       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point 
    362       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfd   ! first douwning point 
    363       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 flux 
     358      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 
    365362      !! 
    366363      INTEGER  ::  ji, jj, jk               ! dummy loop indices  
    … …  
    369366      !---------------------------------------------------------------------- 
    370367      ! 
    371       DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     368      DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    372369         zc     = puc(ji,jj,jk)                         ! Courant number 
    373370         zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traadv_ubs.F90

    r13497 r13992  
    9292      INTEGER                                  , INTENT(in   ) ::   kn_ubs_v        ! number of tracers 
    9393      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     94      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    9495      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
    9596      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    99100      REAL(wp) ::   zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk   !   -      - 
    100101      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. 
    108119      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. 
    117120      ! 
    118121      ztw (:,:, 1 ) = 0._wp      ! surface & bottom value : set to zero for all tracers 
    119122      zltu(:,:,jpk) = 0._wp   ;   zltv(:,:,jpk) = 0._wp 
    120123      ztw (:,:,jpk) = 0._wp   ;   zti (:,:,jpk) = 0._wp 
    121       ! 
    122124      !                                                          ! =========== 
    123125      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    125127         !                                               
    126128         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) 
    128130               zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
    129131               zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
    … …  
    131133               ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    132134            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) 
    134136               zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 
    135137               zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    … …  
    138140            !                                     
    139141         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) 
    141143         !     
    142144         DO_3D( 1, 0, 1, 0, 1, jpkm1 )   !==  Horizontal advective fluxes  ==!     (UBS) 
    … …  
    153155         END_3D 
    154156         ! 
    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 
    156160         ! 
    157161         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==! 
    … …  
    165169         END DO 
    166170         ! 
    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         ! 
    170175         IF( l_trd ) THEN                  ! trend diagnostics 
    171176             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) 
    … …  
    185190         CASE(  2  )                   ! 2nd order FCT  
    186191            !          
    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 
    188197            ! 
    189198            !                               !*  upstream advection with initial mass fluxes & intermediate update  ==! 
    … …  
    199208                  END_2D 
    200209               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 
    202213               ENDIF 
    203214            ENDIF 
    … …  
    209220               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    210221            END_3D 
    211             CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    212222            ! 
    213223            !                          !*  anti-diffusive flux : high order minus low order 
    … …  
    226236               ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    227237            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 
    229243            ! 
    230244         END SELECT 
    … …  
    262276      !!       in-space based differencing for fluid 
    263277      !!---------------------------------------------------------------------- 
    264       INTEGER , INTENT(in   )                          ::   Kmm    ! time level index 
    265       REAL(wp), INTENT(in   )                          ::   p2dt   ! tracer time-step 
    266       REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    267       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
    268       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction 
     278      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 
    269283      ! 
    270284      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    271285      INTEGER  ::   ikm1         ! local integer 
    272286      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn   ! local scalars 
    273       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zbetup, zbetdo     ! 3D workspace 
     287      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zbetup, zbetdo         ! 3D workspace 
    274288      !!---------------------------------------------------------------------- 
    275289      ! 
    … …  
    281295      ! -------------------- 
    282296      !                    ! 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 
    285301      ! 
    286302      DO jk = 1, jpkm1     ! search maximum in neighbourhood 
    … …  
    293309      END DO 
    294310      !                    ! 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 
    297315      ! 
    298316      DO jk = 1, jpkm1     ! search minimum in neighbourhood 
    … …  
    305323      END DO 
    306324      !                    ! 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 
    309329      ! 
    310330      ! Positive and negative part of fluxes and beta terms 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traatf.F90

    r13295 r13992  
    156156         ENDIF 
    157157         ! 
    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 
    162160      ENDIF      
    163161      ! 
    … …  
    210208      DO jn = 1, kjpt 
    211209         ! 
    212          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     210         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    213211            ztn = pt(ji,jj,jk,jn,Kmm)                                     
    214212            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    … …  
    275273      zfact2 = zfact1 * r1_rho0 
    276274      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 ) 
    278276            ze3t_b = e3t(ji,jj,jk,Kbb) 
    279277            ze3t_n = e3t(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traatf_qco.F90

    r13295 r13992  
    149149         ENDIF 
    150150         ! 
    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 
    155153      ENDIF 
    156154      ! 
    … …  
    203201      DO jn = 1, kjpt 
    204202         ! 
    205          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     203         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    206204            ztn = pt(ji,jj,jk,jn,Kmm) 
    207205            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    … …  
    268266      zfact2 = zfact1 * r1_rho0 
    269267      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 ) 
    271269            ze3t_b = e3t(ji,jj,jk,Kbb) 
    272270            ze3t_n = e3t(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/trabbc.F90

    r13295 r13992  
    8080      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    8181      ! 
    82       INTEGER  ::   ji, jj    ! dummy loop indices 
     82      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    8383      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt   ! 3D workspace 
    8484      !!---------------------------------------------------------------------- 
    … …  
    8686      IF( ln_timing )   CALL timing_start('tra_bbc') 
    8787      ! 
    88       IF( l_trdtra )   THEN         ! Save the input temperature trend 
     88      IF( l_trdtra ) THEN           ! Save the input temperature trend 
    8989         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    9090         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    … …  
    9696      END_2D 
    9797      ! 
    98       CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp ) 
    99       ! 
    10098      IF( l_trdtra ) THEN        ! Send the trend for diagnostics 
    10199         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    … …  
    104102      ENDIF 
    105103      ! 
    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 
    107107      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    108108      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/trabbl.F90

    r13532 r13992  
    106106      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    107107      ! 
     108      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    108109      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds 
    109110      !!---------------------------------------------------------------------- 
    … …  
    112113      ! 
    113114      IF( l_trdtra )   THEN                         !* Save the T-S input trends 
    114          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     115         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    115116         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    116117         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    … …  
    125126         CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    126127            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    127          ! lateral boundary conditions ; just need for outputs 
    128          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-coef 
    130          CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
     128         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 
    131132         ! 
    132133      ENDIF 
    … …  
    136137         CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 
    137138         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, & 
    139140            &          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 
    144148         ! 
    145149      ENDIF 
    … …  
    187191      INTEGER  ::   ik           ! local integers 
    188192      REAL(wp) ::   zbtr         ! local scalars 
    189       REAL(wp), DIMENSION(jpi,jpj) ::   zptb   ! workspace 
     193      REAL(wp), DIMENSION(A2D(nn_hls)) ::   zptb   ! workspace 
    190194      !!---------------------------------------------------------------------- 
    191195      ! 
    … …  
    235239      INTEGER  ::   iis , iid , ijs , ijd    ! local integers 
    236240      INTEGER  ::   ikus, ikud, ikvs, ikvd   !   -       - 
     241      INTEGER  ::   isi, isj                 !   -       - 
    237242      REAL(wp) ::   zbtr, ztra               ! local scalars 
    238243      REAL(wp) ::   zu_bbl, zv_bbl           !   -      - 
    239244      !!---------------------------------------------------------------------- 
    240245      ! 
     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 
    241248      !                                                          ! =========== 
    242249      DO jn = 1, kjpt                                            ! tracer loop 
    243250         !                                                       ! =========== 
    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 
    290274            ! 
    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      !                                                          ! =========== 
    295300   END SUBROUTINE tra_bbl_adv 
    296301 
    … …  
    333338      REAL(wp) ::   za, zb, zgdrho            ! local scalars 
    334339      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 
    343350      ENDIF 
    344351      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/tradmp.F90

    r13295 r13992  
    9595      ! 
    9696      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    97       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)     ::  zts_dta 
     97      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts)     ::  zts_dta 
    9898      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  ztrdts 
    9999      !!---------------------------------------------------------------------- 
    … …  
    102102      ! 
    103103      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) 
    106106      ENDIF 
    107107      !                           !==  input T-S data at kt  ==! 
    … …  
    144144         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 
    145145         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 
    146          DEALLOCATE( ztrdts )  
     146         DEALLOCATE( ztrdts ) 
    147147      ENDIF 
    148148      !                           ! Control print 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traisf.F90

    r13295 r13992  
    1111   !!---------------------------------------------------------------------- 
    1212   USE isf_oce                                     ! Ice shelf variables 
     13   USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej 
    1314   USE dom_oce                                     ! ocean space domain variables 
    1415   USE isfutils, ONLY : debug                      ! debug option 
    … …  
    4647      IF( ln_timing )   CALL timing_start('tra_isf') 
    4748      ! 
    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 
    5255      ENDIF 
    5356      ! 
    … …  
    7679      ! 
    7780      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 
    8085      END IF 
    8186      ! 
    … …  
    101106      INTEGER                      :: ji,jj,jk  ! loop index    
    102107      INTEGER                      :: ikt, ikb  ! top and bottom level of the tbl 
    103       REAL(wp), DIMENSION(jpi,jpj) :: ztc       ! total ice shelf tracer trend 
     108      REAL(wp), DIMENSION(A2D(nn_hls))    :: ztc       ! total ice shelf tracer trend 
    104109      !!---------------------------------------------------------------------- 
    105110      ! 
    106111      ! 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 
    108115      ! 
    109116      ! update pts(:,:,:,:,Krhs) 
    110       DO_2D( 1, 1, 1, 1 ) 
     117      DO_2D( 0, 0, 0, 0 ) 
    111118         ! 
    112119         ikt = ktop(ji,jj) 
    … …  
    137144      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) :: ptsc 
    138145      !!---------------------------------------------------------------------- 
    139       INTEGER :: jk 
     146      INTEGER :: ji, jj, jk 
    140147      !!---------------------------------------------------------------------- 
    141148      ! 
    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 
    148153      ! 
    149154   END SUBROUTINE tra_isf_cpl 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traldf.F90

    r12377 r13992  
    1717   USE oce            ! ocean dynamics and tracers 
    1818   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 
    1921   USE phycst         ! physical constants 
    2022   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff. 
    … …  
    3739   PUBLIC   tra_ldf        ! called by step.F90  
    3840   PUBLIC   tra_ldf_init   ! called by nemogcm.F90  
    39     
     41 
    4042   !!---------------------------------------------------------------------- 
    4143   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5658      !! 
    5759      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 
    5862      !!---------------------------------------------------------------------- 
    5963      ! 
    6064      IF( ln_timing )   CALL timing_start('tra_ldf') 
    6165      ! 
     66      lskip = .FALSE. 
     67 
    6268      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) 
    6571         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    6672      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 ) 
    85109      ENDIF 
    86110      !                                        !* 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, & 
    88112         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    89113      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traldf_iso.F90

    r13497 r13992  
    1919   USE oce            ! ocean dynamics and active tracers 
    2020   USE dom_oce        ! ocean space and time domain 
     21   USE domutl, ONLY : is_tile 
    2122   USE trc_oce        ! share passive tracers/Ocean variables 
    2223   USE zdf_oce        ! ocean vertical physics 
    … …  
    4950CONTAINS 
    5051 
    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 ) 
    5478      !!---------------------------------------------------------------------- 
    5579      !!                  ***  ROUTINE tra_ldf_iso  *** 
    … …  
    92116      !! ** Action :   Update pt_rhs arrays with the before rotated diffusion 
    93117      !!---------------------------------------------------------------------- 
    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 
    106131      ! 
    107132      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    111136      REAL(wp) ::  zmskv, zahv_w, zabe2, zcof2, zcoef4   !   -      - 
    112137      REAL(wp) ::  zcoef0, ze3w_2, zsign                 !   -      - 
    113       REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt, zdk1t, z2d 
    114       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw  
     138      REAL(wp), DIMENSION(A2D(nn_hls))     ::   zdkt, zdk1t, z2d 
     139      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zdit, zdjt, zftu, zftv, ztfw 
    115140      !!---------------------------------------------------------------------- 
    116141      ! 
    117142      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 
    124153      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 
    131162      ! 
    132163      ! 
    … …  
    167198            ! 
    168199            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 ) 
    170201                  akz(ji,jj,jk) = 16._wp   & 
    171202                     &   * ah_wslp2   (ji,jj,jk)   & 
    … …  
    175206               END_3D 
    176207            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 ) 
    178209                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    179210                  zcoef0 = rDt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    … …  
    183214           ! 
    184215         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 
    186219         ENDIF 
    187220      ENDIF 
    … …  
    195228         !!---------------------------------------------------------------------- 
    196229!!gm : bug.... why (x,:,:)?   (1,jpj,:) and (jpi,1,:) should be sufficient.... 
    197          zdit (1,:,:) = 0._wp     ;     zdit (jpi,:,:) = 0._wp 
    198          zdjt (1,:,:) = 0._wp     ;     zdjt (jpi,:,:) = 0._wp 
     230         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 
    199232         !!end 
    200233 
    … …  
    223256         DO jk = 1, jpkm1                                 ! Horizontal slab 
    224257            ! 
    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            ! 
    231267            DO_2D( 1, 0, 1, 0 )           !==  Horizontal fluxes 
    232268               zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    … …  
    330366      END DO                                                      ! end tracer loop 
    331367      ! 
    332    END SUBROUTINE tra_ldf_iso 
     368   END SUBROUTINE tra_ldf_iso_t 
    333369 
    334370   !!============================================================================== 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traldf_lap_blp.F90

    r13497 r13992  
    1313   USE oce            ! ocean dynamics and active tracers 
    1414   USE dom_oce        ! ocean space and time domain 
     15   USE domutl, ONLY : is_tile 
    1516   USE ldftra         ! lateral physics: eddy diffusivity 
    1617   USE traldf_iso     ! iso-neutral lateral diffusion (standard operator)     (tra_ldf_iso   routine) 
    … …  
    4647CONTAINS 
    4748 
    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 ) 
    5174      !!---------------------------------------------------------------------- 
    5275      !!                  ***  ROUTINE tra_ldf_lap  *** 
    … …  
    7295      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    7396      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 
    96123      ! 
    97124      !                                !==  Initialization of metric arrays used for all tracers  ==! 
    … …  
    99126      ELSE                    ;   zsign = -1._wp 
    100127      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)  ==! 
    102135         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! 
    103136         zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   !!gm   * vmask(ji,jj,jk) 
    … …  
    108141         !                          ! =========== !     
    109142         !                                
    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)  ==! 
    111144            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
    112145            ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
    113146         END_3D 
    114147         IF( ln_zps ) THEN                             ! set gradient at bottom/top ocean level 
    115             DO_2D( 1, 0, 1, 0 )                              ! bottom 
     148            DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )                              ! bottom 
    116149               ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
    117150               ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
    118151            END_2D 
    119152            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 ) 
    121154                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    122155                  IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
    … …  
    125158         ENDIF 
    126159         ! 
    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  ==! 
    128162            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    129163               &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
    … …  
    142176      !                             ! ================== 
    143177      ! 
    144    END SUBROUTINE tra_ldf_lap 
     178   END SUBROUTINE tra_ldf_lap_t 
    145179    
    146180 
    … …  
    173207      ! 
    174208      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    175       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap         ! laplacian at t-point 
    176       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) 
    178212      !!--------------------------------------------------------------------- 
    179213      ! 
    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 
    188224      ENDIF 
    189225 
    … …  
    200236      END SELECT 
    201237      ! 
     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 
    202239      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp )     ! Lateral boundary conditions (unchanged sign) 
    203240      !                                               ! Partial top/bottom cell: GRADh( zlap )   

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traldf_triad.F90

    r13497 r13992  
    1313   USE oce            ! ocean dynamics and active tracers 
    1414   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 
    1518   USE phycst         ! physical constants 
    1619   USE trc_oce        ! share passive tracers/Ocean variables 
    … …  
    3336   PUBLIC   tra_ldf_triad   ! routine called by traldf.F90 
    3437 
    35    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE ::   zdkt3d   !: vertical tracer gradient at 2 levels 
    36  
    3738   LOGICAL  ::   l_ptr   ! flag to compute poleward transport 
    3839   LOGICAL  ::   l_hst   ! flag to compute heat transport 
    … …  
    4950CONTAINS 
    5051 
    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 ) 
    5478      !!---------------------------------------------------------------------- 
    5579      !!                  ***  ROUTINE tra_ldf_triad  *** 
    … …  
    77101      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    78102      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 
    85110      ! 
    86111      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    94119      REAL(wp) ::   ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 
    95120      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 
    98126      !!---------------------------------------------------------------------- 
    99127      ! 
    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 
    118142      ENDIF 
    119143      ! 
    … …  
    128152      IF( kpass == 1 ) THEN         !==  first pass only  and whatever the tracer is  ==! 
    129153         ! 
    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 
    136158         ! 
    137159         DO ip = 0, 1                            ! i-k triads 
    138160            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) 
    144166                  ! 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) 
    146168                  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) * zslope2 
    148                   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) 
    150172                     ! 
    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_skew 
    153173               END_3D 
    154174            END DO 
    … …  
    157177         DO jp = 0, 1                            ! j-k triads  
    158178            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) 
    164184                  ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
    165185                  !    (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) 
    167187                  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) * zslope2 
    169                   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) 
    171191                  ! 
    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_skew 
    174192               END_3D 
    175193            END DO 
    … …  
    179197            ! 
    180198            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 ) 
    182200                  akz(ji,jj,jk) = 16._wp           & 
    183201                     &   * ah_wslp2   (ji,jj,jk)   & 
    … …  
    187205               END_3D 
    188206            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 ) 
    190208                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    191209                  zcoef0 = rDt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    … …  
    195213           ! 
    196214         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 
    201243         ! 
    202244      ENDIF                                  !==  end 1st pass only  ==! 
    … …  
    234276         DO jk = 1, jpkm1 
    235277            !                    !==  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 
    237281            ! 
    238282            !                    ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) 
    239283            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 
    241288            ENDIF 
    242289            ! 
    … …  
    380427      END DO                                                      ! end tracer loop 
    381428      !                                                           ! =============== 
    382    END SUBROUTINE tra_ldf_triad 
     429   END SUBROUTINE tra_ldf_triad_t 
    383430 
    384431   !!============================================================================== 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/tramle.F90

    r13497 r13992  
    7979      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
    8080      !!---------------------------------------------------------------------- 
    81       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(jpi,jpj,jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
    86       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pv         ! out: same 3  transport components 
    87       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport 
     81      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 
    8888      ! 
    8989      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
    … …  
    9191      REAL(wp) ::   zcuw, zmuw, zc      ! local scalar 
    9292      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 
    9699      !!---------------------------------------------------------------------- 
    97100      ! 
    98101      !                                      !==  MLD used for MLE  ==! 
    99102      !                                                ! 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 
    101106      IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    102107         DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
    … …  
    135140      END SELECT 
    136141      !                                                ! 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 
    138145      ! 
    139146      ! 
    … …  
    206213      END DO 
    207214 
     215      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
    208216      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 
    212225         ! 
    213226         ! 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 
    220238      ENDIF 
    221239      ! 
    … …  
    283301            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    284302            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    285             DO_2D( 0, 1, 0, 1 )                      ! "coriolis+ time^-1" at u- & v-points 
     303            DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )                      ! "coriolis+ time^-1" at u- & v-points 
    286304               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    287305               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
    … …  
    289307               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    290308            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 ) 
    292310            ! 
    293311         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/tranpc.F90

    r13497 r13992  
    1717   USE oce            ! ocean dynamics and active tracers 
    1818   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 
    1921   USE phycst         ! physical constants 
    2022   USE zdf_oce        ! ocean vertical physics 
    … …  
    3234 
    3335   PUBLIC   tra_npc    ! routine called by step.F90 
     36 
     37   INTEGER  ::   nnpcc        ! number of statically instable water column 
    3438 
    3539   !! * Substitutions 
    … …  
    6468      ! 
    6569      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    66       INTEGER  ::   inpcc        ! number of statically instable water column 
    6770      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers 
    6871      LOGICAL  ::   l_bottom_reached, l_column_treated 
    … …  
    7073      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt 
    7174      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 point 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk     )   ::   zn2          ! N^2  
    75       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)   ::   zab          ! alpha and beta 
     75      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 
    7679      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds ! 3D workspace 
    7780      ! 
    7881      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
    7982      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1" 
     83      INTEGER :: isi, isj, iei, iej 
    8084      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu" 
    8185      !!---------------------------------------------------------------------- 
    … …  
    8791         IF( l_trdtra )   THEN                    !* Save initial after fields 
    8892            ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    89             ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa)  
     93            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    9094            ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    9195         ENDIF 
    … …  
    101105         CALL bn2    ( pts(:,:,:,:,Kaa), zab, zn2, Kmm )    ! after Brunt-Vaisala  (given on W-points) 
    102106         ! 
    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 
    106116            ! 
    107117            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
    … …  
    160170                        ENDIF 
    161171                        ! 
    162                         IF( jiter == 1 )   inpcc = inpcc + 1  
     172                        IF( jiter == 1 )   nnpcc = nnpcc + 1 
    163173                        ! 
    164174                        IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    … …  
    310320         ENDIF 
    311321         ! 
    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 ) THEN 
    315             WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 
    316             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 
    317327         ENDIF 
    318328         ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/traqsr.F90

    r13497 r13992  
    2222   USE phycst         ! physical constants 
    2323   USE dom_oce        ! ocean space and time domain 
     24   USE domain, ONLY : dom_tile 
    2425   USE sbc_oce        ! surface boundary condition: ocean 
    2526   USE trc_oce        ! share SMS/Ocean variables 
    … …  
    107108      ! 
    108109      INTEGER  ::   ji, jj, jk               ! dummy loop indices 
    109       INTEGER  ::   irgb                    ! local integers 
     110      INTEGER  ::   irgb, isi, iei, isj, iej ! local integers 
    110111      REAL(wp) ::   zchl, zcoef, z1_2        ! local scalars 
    111112      REAL(wp) ::   zc0 , zc1 , zc2 , zc3    !    -         - 
    … …  
    120121      IF( ln_timing )   CALL timing_start('tra_qsr') 
    121122      ! 
    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 
    126129      ENDIF 
    127130      ! 
    128131      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend 
    129          ALLOCATE( ztrdt(jpi,jpj,jpk) )  
     132         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    130133         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    131134      ENDIF 
    … …  
    134137      !                         !  before qsr induced heat content  ! 
    135138      !                         !-----------------------------------! 
     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 
    136145      IF( kt == nit000 ) THEN          !==  1st time step  ==! 
    137146         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' 
    139147            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 
    141152         ELSE                                           ! No restart or restart not found: Euler forward time stepping 
    142153            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 
    144157         ENDIF 
    145158      ELSE                             !==  Swap of qsr heat content  ==! 
    146159         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 
    148163      ENDIF 
    149164      ! 
    … …  
    154169      CASE( np_BIO )                   !==  bio-model fluxes  ==! 
    155170         ! 
    156          DO jk = 1, nksr 
    157             qsr_hc(:,:,jk) = r1_rho0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 
    158          END DO 
     171         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 
    159174         ! 
    160175      CASE( np_RGB , np_RGBc )         !==  R-G-B fluxes  ==! 
    161176         ! 
    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)                     ) 
    165180         ! 
    166181         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 
    168187            ! 
    169188            ! Separation in R-G-B depending on the surface Chl 
    … …  
    172191            ! most expensive calculations) 
    173192            ! 
    174             DO_2D( 0, 0, 0, 0 ) 
     193            DO_2D( isj, iej, isi, iei ) 
    175194                       ! zlogc = log(zchl) 
    176195               zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) )      
    … …  
    191210             
    192211! 
    193             DO_3D( 0, 0, 0, 0, 1, nksr + 1 ) 
     212            DO_3D( isj, iej, isi, iei, 1, nksr + 1 ) 
    194213               ! zchl    = ALOG( ze0(ji,jj) ) 
    195214               zlogc = ze0(ji,jj) 
    … …  
    216235            zlui = 41 + 20.*LOG10(zchl) + 1.e-15 
    217236            DO jk = 1, nksr + 1 
    218                ztmp3d(:,:,jk) = zlui  
     237               ztmp3d(:,:,jk) = zlui 
    219238            END DO 
    220239         ENDIF 
    221240         ! 
    222241         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 ) 
    224243            ze0(ji,jj) = rn_abs * qsr(ji,jj) 
    225244            ze1(ji,jj) = zcoef  * qsr(ji,jj) 
    … …  
    232251         ! 
    233252         !                                    !* 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 ) 
    235254            ze3t = e3t(ji,jj,jk-1,Kmm) 
    236255            irgb = NINT( ztmp3d(ji,jj,jk) ) 
    … …  
    246265         END_3D 
    247266         ! 
    248          DO_3D( 0, 0, 0, 0, 1, nksr )          !* now qsr induced heat content 
     267         DO_3D( isj, iej, isi, iei, 1, nksr )          !* now qsr induced heat content 
    249268            qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 
    250269         END_3D 
    … …  
    256275         zz0 =        rn_abs   * r1_rho0_rcp      ! surface equi-partition in 2-bands 
    257276         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 400m  
     277         DO_3D( isj, iej, isi, iei, 1, nksr )          !* now qsr induced heat content 
    259278            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
    260279            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
    … …  
    274293      ! 
    275294      ! sea-ice: store the 1st ocean level attenuation coefficient 
    276       DO_2D( 0, 0, 0, 0 ) 
     295      DO_2D( isj, iej, isi, iei ) 
    277296         IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) 
    278297         ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    279298         ENDIF 
    280299      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 
    298319      ENDIF 
    299320      ! 
    … …  
    301322         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    302323         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    303          DEALLOCATE( ztrdt )  
     324         DEALLOCATE( ztrdt ) 
    304325      ENDIF 
    305326      !                       ! print mean trends (used for debugging) 
    … …  
    431452      ! 1st ocean level attenuation coefficient (used in sbcssm) 
    432453      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  ) 
    434455      ELSE 
    435456         fraqsr_1lev(:,:) = 1._wp   ! default : no penetration 
    436457      ENDIF 
    437458      ! 
    438       IF( lwxios ) THEN 
    439          CALL iom_set_rstw_var_active('qsr_hc_b') 
    440          CALL iom_set_rstw_var_active('fraqsr_1lev') 
    441       ENDIF 
    442       ! 
    443459   END SUBROUTINE tra_qsr_init 
    444460 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/trasbc.F90

    r13497 r13992  
    7676      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    7777      ! 
    78       INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices   
    79       INTEGER  ::   ikt, ikb                    ! local integers 
    80       REAL(wp) ::   zfact, z1_e3t, zdep, ztim   ! local scalar 
     78      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 
    8181      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    8282      !!---------------------------------------------------------------------- 
    … …  
    8484      IF( ln_timing )   CALL timing_start('tra_sbc') 
    8585      ! 
    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 
    9092      ENDIF 
    9193      ! 
    9294      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) ) 
    9496         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    9597         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    9698      ENDIF 
    9799      ! 
     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 
    98106!!gm  This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 
    99107      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 
    102112      ENDIF 
    103113 
    … …  
    109119         IF( ln_rstart .AND.    &               ! Restart: read in restart file 
    110120              & 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' 
    112121            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 
    116128         ELSE                                   ! No restart or restart not found: Euler forward time stepping 
    117129            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 
    120134         ENDIF 
    121135      ELSE                                !* other time-steps: swap of forcing fields 
    122136         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 
    124140      ENDIF 
    125141      !                             !==  Now sbc tracer content fields  ==! 
    126       DO_2D( 0, 1, 0, 0 ) 
     142      DO_2D( isj, iej, isi, iei ) 
    127143         sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj)   ! non solar heat flux 
    128144         sbc_tsc(ji,jj,jp_sal) = r1_rho0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
    129145      END_2D 
    130146      IF( ln_linssh ) THEN                !* linear free surface   
    131          DO_2D( 0, 1, 0, 0 )                    !==>> add concentration/dilution effect due to constant volume cell 
     147         DO_2D( isj, iej, isi, iei )                    !==>> add concentration/dilution effect due to constant volume cell 
    132148            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    133149            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
    134150         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 
    137155      ENDIF 
    138156      ! 
    139157      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 ) 
    141160            pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) )    & 
    142161               &                                                / e3t(ji,jj,1,Kmm) 
    … …  
    144163      END DO 
    145164      !                   
    146       IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==! 
    147          IF( lwxios ) 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 
    151170      ENDIF 
    152171      ! 
    … …  
    157176      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
    158177         zfact = 0.5_wp 
    159          DO_2D( 0, 1, 0, 0 ) 
     178         DO_2D( 0, 0, 0, 0 ) 
    160179            IF( rnf(ji,jj) /= 0._wp ) THEN 
    161180               zdep = zfact / h_rnf(ji,jj) 
    … …  
    170189      ENDIF 
    171190 
    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 
    174195 
    175196#if defined key_asminc 
    … …  
    182203          ! 
    183204         IF( ln_linssh ) THEN  
    184             DO_2D( 0, 1, 0, 0 ) 
     205            DO_2D( 0, 0, 0, 0 ) 
    185206               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
    186207               pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
    … …  
    188209            END_2D 
    189210         ELSE 
    190             DO_2D( 0, 1, 0, 0 ) 
     211            DO_2D( 0, 0, 0, 0 ) 
    191212               ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
    192213               pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
    … …  
    204225         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
    205226         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    206          DEALLOCATE( ztrdt , ztrds )  
     227         DEALLOCATE( ztrdt , ztrds ) 
    207228      ENDIF 
    208229      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/trazdf.F90

    r13826 r13992  
    1313   !!---------------------------------------------------------------------- 
    1414   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 
    1616   USE domvvl         ! variable volume 
    1717   USE phycst         ! physical constant 
    … …  
    5656      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5757      ! 
    58       INTEGER  ::   jk   ! Dummy loop indices 
     58      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    5959      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    6060      !!--------------------------------------------------------------------- 
    … …  
    6363      ! 
    6464      IF( kt == nit000 )  THEN 
    65          IF(lwp)WRITE(numout,*) 
    66          IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
    67          IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     65         IF( ntile == 0 .OR. ntile == 1 )  THEN                   ! Do only on the first tile 
     66            IF(lwp)WRITE(numout,*) 
     67            IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
     68            IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     69         ENDIF 
    6870      ENDIF 
    6971      ! 
    7072      IF( l_trdtra )   THEN                  !* Save ta and sa trends 
    71          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     73         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    7274         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    7375         ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    … …  
    8183      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    8284      ! JMM : restore negative salinities to small salinities: 
    83       WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp )   pts(:,:,:,jp_sal,Kaa) = 0.1_wp 
     85      WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp )   pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 
    8486!!gm 
    8587 
    8688      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    87          DO jk = 1, jpkm1 
     89         DO jk = 1, jpk 
    8890            ztrdt(:,:,jk) = (   (  pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa)     & 
    8991               &                 - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb)  )  & 
    … …  
    9597               &          - ztrds(:,:,jk) 
    9698         END DO 
     99         ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
    97100!!gm this should be moved in trdtra.F90 and done on all trends 
    98101         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
    … …  
    141144      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    142145      REAL(wp) ::  zrhs, zzwi, zzws ! local scalars 
    143       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws 
     146      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::  zwi, zwt, zwd, zws 
    144147      !!--------------------------------------------------------------------- 
    145148      ! 
    … …  
    155158            ! 
    156159            ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 
    157             IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN   ;   zwt(:,:,2:jpk) = avt(:,:,2:jpk) 
    158             ELSE                                            ;   zwt(:,:,2:jpk) = avs(:,:,2:jpk) 
     160            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 
     161               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     162                  zwt(ji,jj,jk) = avt(ji,jj,jk) 
     163               END_3D 
     164            ELSE 
     165               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     166                  zwt(ji,jj,jk) = avs(ji,jj,jk) 
     167               END_3D 
    159168            ENDIF 
    160169            zwt(:,:,1) = 0._wp 
    … …  
    233242         END_2D 
    234243         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    235             zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    &  
     244            zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    & 
    236245               & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
    237246            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/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRA/zpshde.F90

    r13497 r13992  
    1717   USE oce             ! ocean: dynamics and tracers variables 
    1818   USE dom_oce         ! domain: ocean variables 
     19   USE domutl, ONLY : is_tile 
    1920   USE phycst          ! physical constants 
    2021   USE eosbn2          ! ocean equation of state 
    … …  
    4041CONTAINS 
    4142 
    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 ) 
    4466      !!---------------------------------------------------------------------- 
    4567      !!                     ***  ROUTINE zps_hde  *** 
    … …  
    85107      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 
    86108      !!---------------------------------------------------------------------- 
    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) 
    94117      ! 
    95118      INTEGER  ::   ji, jj, jn                  ! Dummy loop indices 
    96119      INTEGER  ::   iku, ikv, ikum1, ikvm1      ! partial step level (ocean bottom level) at u- and v-points 
    97120      REAL(wp) ::   ze3wu, ze3wv, zmaxu, zmaxv  ! local scalars 
    98       REAL(wp), DIMENSION(jpi,jpj)      ::   zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    99       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             ! 
    100123      !!---------------------------------------------------------------------- 
    101124      ! 
    102125      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 
    103131      ! 
    104132      pgtu(:,:,:) = 0._wp   ;   zti (:,:,:) = 0._wp   ;   zhi (:,:) = 0._wp 
    … …  
    107135      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    108136         ! 
    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 
    110138            iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    111139            ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    … …  
    146174      END DO 
    147175      ! 
    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. 
    149177      !                 
    150178      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    151179         pgru(:,:) = 0._wp 
    152180         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 ) 
    154182            iku = mbku(ji,jj) 
    155183            ikv = mbkv(ji,jj) 
    … …  
    167195         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    168196         ! 
    169          DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
     197         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )              ! Gradient of density at the last level 
    170198            iku = mbku(ji,jj) 
    171199            ikv = mbkv(ji,jj) 
    … …  
    179207            ENDIF 
    180208         END_2D 
    181          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     209         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    182210         ! 
    183211      END IF 
    … …  
    185213      IF( ln_timing )   CALL timing_stop( 'zps_hde') 
    186214      ! 
    187    END SUBROUTINE zps_hde 
     215   END SUBROUTINE zps_hde_t 
    188216 
    189217 
    190218   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 ) 
    192244      !!---------------------------------------------------------------------- 
    193245      !!                     ***  ROUTINE zps_hde_isf  *** 
    … …  
    236288      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
    237289      !!---------------------------------------------------------------------- 
    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) 
    247300      ! 
    248301      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    249302      INTEGER  ::   iku, ikv, ikum1, ikvm1,ikup1, ikvp1   ! partial step level (ocean bottom level) at u- and v-points 
    250303      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv             ! temporary scalars 
    251       REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    252       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             ! 
    253306      !!---------------------------------------------------------------------- 
    254307      ! 
    255308      IF( ln_timing )   CALL timing_start( 'zps_hde_isf') 
    256309      ! 
     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 
    257315      pgtu (:,:,:) = 0._wp   ;   pgtv (:,:,:) =0._wp 
    258316      pgtui(:,:,:) = 0._wp   ;   pgtvi(:,:,:) =0._wp 
    … …  
    262320      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    263321         ! 
    264          DO_2D( 1, 0, 1, 0 ) 
     322         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    265323 
    266324            iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    … …  
    302360      END DO 
    303361      ! 
    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. 
    305363 
    306364      ! horizontal derivative of density anomalies (rd) 
    … …  
    308366         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
    309367         ! 
    310          DO_2D( 1, 0, 1, 0 ) 
     368         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    311369 
    312370            iku = mbku(ji,jj) 
    … …  
    329387         CALL eos( ztj, zhj, zrj ) 
    330388 
    331          DO_2D( 1, 0, 1, 0 )            ! Gradient of density at the last level 
     389         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    332390            iku = mbku(ji,jj) 
    333391            ikv = mbkv(ji,jj) 
    … …  
    344402         END_2D 
    345403 
    346          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     404         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    347405         ! 
    348406      END IF 
    … …  
    351409      ! 
    352410      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 ) 
    354412            iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
    355413            ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
    … …  
    395453         ! 
    396454      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. 
    398456 
    399457      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    400458         ! 
    401459         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 ) 
    403461 
    404462            iku = miku(ji,jj) 
    … …  
    420478         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    421479         ! 
    422          DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
     480         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    423481            iku = miku(ji,jj)  
    424482            ikv = mikv(ji,jj)  
    … …  
    434492 
    435493         END_2D 
    436          CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
     494         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
    437495         ! 
    438496      END IF   
    … …  
    440498      IF( ln_timing )   CALL timing_stop( 'zps_hde_isf') 
    441499      ! 
    442    END SUBROUTINE zps_hde_isf 
     500   END SUBROUTINE zps_hde_isf_t 
    443501 
    444502   !!====================================================================== 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/TRD/trdini.F90

    r12377 r13992  
    1111   !!---------------------------------------------------------------------- 
    1212   USE dom_oce        ! ocean domain 
     13   USE domain, ONLY : dom_tile 
    1314   USE trd_oce        ! trends: ocean variables 
    1415   USE trdken         ! trends: 3D kinetic   energy 
    … …  
    8889      ! 
    8990!      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 
    9198!!gm  : Potential BUG : 3D output only for vector invariant form!  add a ctl_stop or code the flux form case 
    9299!!gm  : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output...  

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/USR/usrdef_nam.F90

    r13286 r13992  
    7070      kk_cfg = nn_GYRE 
    7171      ! 
    72       kpi = 30 * nn_GYRE + 2       !                      
     72      kpi = 30 * nn_GYRE + 2       ! 
    7373      kpj = 20 * nn_GYRE + 2 
    7474#if defined key_agrif 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ZDF/zdfgls.F90

    r13558 r13992  
    10571057      CALL gls_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, hmxl_n) 
    10581058      ! 
    1059       IF( lwxios ) THEN 
    1060          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       ENDIF 
    1065       ! 
    10661059   END SUBROUTINE zdf_gls_init 
    10671060 
    … …  
    10971090            ! 
    10981091            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 ) 
    11031096            ELSE                         
    11041097               IF(lwp) WRITE(numout,*) 
    … …  
    11191112         !                                   ! ------------------- 
    11201113         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 ) 
    11271118         ! 
    11281119      ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ZDF/zdfosm.F90

    r13497 r13992  
    14371437     ghamv(:,:,:) = 0. 
    14381438     ! 
    1439      IF( lwxios ) THEN 
    1440         CALL iom_set_rstw_var_active('wn') 
    1441         CALL iom_set_rstw_var_active('hbl') 
    1442         CALL iom_set_rstw_var_active('hbli') 
    1443      ENDIF 
    14441439   END SUBROUTINE zdf_osm_init 
    14451440 
    … …  
    14741469        id1 = iom_varid( numror, 'wn'   , ldstop = .FALSE. ) 
    14751470        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 ) 
    14771472           WRITE(numout,*) ' ===>>>> :  ww read from restart file' 
    14781473        ELSE 
    … …  
    14831478        id2 = iom_varid( numror, 'hbli'   , ldstop = .FALSE. ) 
    14841479        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  ) 
    14871482           WRITE(numout,*) ' ===>>>> :  hbl & hbli read from restart file' 
    14881483           RETURN 
    … …  
    14961491     !!----------------------------------------------------------------------------- 
    14971492     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 
    14981495        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 ) 
    15021499        RETURN 
    15031500     END IF 
    … …  
    15501547      ! 
    15511548      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 
    15551554      ENDIF 
    15561555 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ZDF/zdfric.F90

    r13497 r13992  
    103103      CALL ric_rst( nit000, 'READ' )  !* read or initialize all required files 
    104104      ! 
    105       IF( lwxios ) THEN 
    106          CALL iom_set_rstw_var_active('avt_k') 
    107          CALL iom_set_rstw_var_active('avm_k') 
    108       ENDIF 
    109105   END SUBROUTINE zdf_ric_init 
    110106 
    … …  
    214210            ! 
    215211            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 ) 
    218214            ENDIF 
    219215         ENDIF 
    … …  
    223219         !                                   ! ------------------- 
    224220         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) 
    229223         ! 
    230224      ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/ZDF/zdftke.F90

    r13558 r13992  
    721721      CALL tke_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, dissl)  
    722722      ! 
    723       IF( lwxios ) THEN 
    724          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       ENDIF 
    729723   END SUBROUTINE zdf_tke_init 
    730724 
    … …  
    758752            ! 
    759753            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 ) 
    764758            ELSE                                          ! start TKE from rest 
    765759               IF(lwp) WRITE(numout,*) 
    … …  
    780774         !                                   ! ------------------- 
    781775         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 ) 
    788780         ! 
    789781      ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/do_loop_substitute.h90

    r13296 r13992  
    5959#endif 
    6060 
    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  : 
    6271 
    6372#define DO_3D(B, T, L, R, ks, ke) DO jk = ks, ke   ;   DO_2D(B, T, L, R) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/nemogcm.F90

    r13558 r13992  
    437437     CALL Agrif_Declare_Var_ini   !  "      "   "   "      "  DOM 
    438438#endif 
    439                            CALL     dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 
     439                           CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    440440      IF( ln_crs       )   CALL     crs_init(      Nnn )       ! coarsened grid: domain initialization  
    441441      IF( sn_cfctl%l_prtctl )   & 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/par_oce.F90

    r13286 r13992  
    6565   INTEGER, PUBLIC ::   jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls            !: maximum jpj 
    6666 
     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 
    6775   !!--------------------------------------------------------------------- 
    6876   !! Active tracer parameters 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/step.F90

    r13826 r13992  
    5555   INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs          !! used by nemo_init 
    5656 
     57   !! * Substitutions 
     58#  include "do_loop_substitute.h90" 
    5759   !!---------------------------------------------------------------------- 
    5860   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8587      !!              -8- Outputs and diagnostics 
    8688      !!---------------------------------------------------------------------- 
    87       INTEGER ::   ji, jj, jk   ! dummy loop indice 
     89      INTEGER ::   ji, jj, jk, jtile   ! dummy loop indice 
    8890!!gm kcall can be removed, I guess 
    8991      INTEGER ::   kcall        ! optional integer argument (dom_vvl_sf_nxt) 
    … …  
    124126         IF( ln_crs      )   CALL iom_init( TRIM(cxios_context)//"_crs" )  ! for coarse grid 
    125127      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 
    126145      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    127146                             CALL iom_setkt( kstp - nit000 + 1,      cxios_context          )   ! tell IOM we are at time step kstp 
    … …  
    246265      ! Active tracers                               
    247266      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    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_zdfmfc  )   CALL tra_mfc    ( kstp, Nbb,      ts, Nrhs )  ! Mass Flux Convection  
    265       IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
    266       IF( lrst_oce .AND. ln_zdfosm ) & 
    267            &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
    268                          CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
    269  
    270                          CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
    271       IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
    272  
     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_zdfmfc  )   CALL tra_mfc    ( kstp, Nbb,      ts, Nrhs )  ! Mass Flux Convection  
     299         IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
     300         IF( lrst_oce .AND. ln_zdfosm ) & 
     301              &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
     302                            CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
     303 
     304                            CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
     305         IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
     306      END DO 
     307 
     308      IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Revert to tile over full domain 
    273309      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    274310      ! Set boundary conditions, time filter and swap time levels 
    … …  
    339375      IF( kstp == nit000 ) THEN                          ! 1st time step only 
    340376                                        CALL iom_close( numror )   ! close input  ocean restart file 
     377         IF( lrxios )                   CALL iom_context_finalize(      cr_ocerst_cxt         ) 
    341378         IF(lwm)                        CALL FLUSH    ( numond )   ! flush output namelist oce 
    342379         IF(lwm .AND. numoni /= -1 )    CALL FLUSH    ( numoni )   ! flush output namelist ice (if exist) 
    … …  
    354391      IF( kstp == nitend .OR. nstop > 0 ) THEN  
    355392                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    356          IF( lrxios ) CALL iom_context_finalize(      crxios_context         ) 
    357393         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    358394      ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/step_oce.F90

    r13826 r13992  
    99   USE oce             ! ocean dynamics and tracers variables 
    1010   USE dom_oce         ! ocean space and time domain variables 
     11   USE domain, ONLY : dom_tile 
    1112   USE zdf_oce         ! ocean vertical physics variables 
    1213   USE zdfdrg  ,  ONLY : ln_drgimp   ! implicit top/bottom friction 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/stpMLF.F90

    r13237 r13992  
    364364      IF( kstp == nitend .OR. indic < 0 ) THEN 
    365365                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    366          IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     366         IF(lrxios) CALL iom_context_finalize(      cr_ocerst_cxt          ) 
    367367         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 
    368368      ENDIF 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OCE/timing.F90

    r13558 r13992  
    109109 
    110110      s_timer%l_tdone = .FALSE. 
    111       s_timer%niter = s_timer%niter + 1 
     111      IF( ntile == 0 .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1      ! All tiles count as one iteration 
    112112      s_timer%t_cpu = 0. 
    113113      s_timer%t_clock = 0. 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OFF/dtadyn.F90

    r13497 r13992  
    4646   USE fldread         ! read input fields  
    4747   USE timing          ! Timing 
    48    USE trc, ONLY : ln_rsttr, numrtr, numrtw, lrst_trc 
     48   USE trc, ONLY : ln_rsttr, lrst_trc 
    4949 
    5050   IMPLICIT NONE 
    … …  
    795795      !!--------------------------------------------------------------------- 
    796796      INTEGER ,                              INTENT(in ) :: kt       ! time step 
    797       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts      ! temperature/salinity 
     797      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts      ! temperature/salinity 
    798798      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(out) :: puslp    ! zonal isopycnal slopes 
    799799      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(out) :: pvslp    ! meridional isopycnal slopes 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/OFF/nemogcm.F90

    r13558 r13992  
    126126         ENDIF 
    127127         ! 
     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 
    128134         IF( istp /= nit000 )   CALL day        ( istp )         ! Calendar (day was already called at nit000 in day_init) 
    129135                                CALL iom_setkt  ( istp - nit000 + 1, cxios_context )   ! say to iom that we are at time step kstp 
    … …  
    340346                           CALL     eos_init        ! Equation of state 
    341347      IF( lk_c1d       )   CALL     c1d_init        ! 1D column configuration 
    342                            CALL     dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 
     348                           CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    343349      IF( sn_cfctl%l_prtctl )   & 
    344350         &                 CALL prt_ctl_init        ! Print control 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SAO/nemogcm.F90

    r13286 r13992  
    235235                           CALL phy_cst            ! Physical constants 
    236236                           CALL eos_init           ! Equation of state 
    237                            CALL dom_init( Nbb, Nnn, Naa, 'SAO')    ! Domain 
     237                           CALL dom_init( Nbb, Nnn, Naa )    ! Domain 
    238238 
    239239 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SAS/nemogcm.F90

    r13558 r13992  
    374374     CALL Agrif_Declare_Var_ini   !  "      "   "   "      "  DOM 
    375375#endif 
    376                            CALL dom_init( Nbb, Nnn, Naa, 'SAS') ! Domain 
     376                           CALL dom_init( Nbb, Nnn, Naa ) ! Domain 
    377377      IF( sn_cfctl%l_prtctl )   & 
    378378         &                 CALL prt_ctl_init        ! Print control 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SAS/step.F90

    r12933 r13992  
    8989#endif    
    9090      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 
    91102      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 
    93111 
    94112      ! ==> clem: open boundaries is mandatory for sea-ice because ice BDY is not decoupled from   
    … …  
    128146      ! File manipulation at the end of the first time step 
    129147      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<                          
    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 
    131152       
    132153      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    140161            CALL iom_close( numrow )      
    141162         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 
    143166         ENDIF 
    144167         lrst_oce = .FALSE. 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/domain.F90

    r13458 r13992  
    6666CONTAINS 
    6767 
    68    SUBROUTINE dom_init( Kbb, Kmm, Kaa, cdstr ) 
     68   SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 
    6969      !!---------------------------------------------------------------------- 
    7070      !!                  ***  ROUTINE dom_init  *** 
    … …  
    8282      !!---------------------------------------------------------------------- 
    8383      INTEGER          , INTENT(in) :: Kbb, Kmm, Kaa          ! ocean time level indices 
    84       CHARACTER (len=*), INTENT(in) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables 
    8584      ! 
    8685!!st6 
    … …  
    135134      CALL dom_nam                     ! read namelist ( namrun, namdom ) 
    136135      ! 
    137       IF( lwxios ) THEN 
    138 !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       ENDIF 
    142 !reset namelist for SAS 
    143       IF(cdstr == 'SAS') THEN 
    144          IF(lrxios) THEN 
    145                IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' 
    146                lrxios = .FALSE. 
    147          ENDIF 
    148       ENDIF 
    149       ! 
    150136      CALL dom_hgr                      ! Horizontal mesh 
    151137 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/domvvl.F90

    r13472 r13992  
    11051105         IF( ln_rstart ) THEN                   !* Read the restart file 
    11061106            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)    ) 
    11081108            ! 
    11091109            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    11181118            ! 
    11191119            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) ) 
    11221122               ! needed to restart if land processor not computed  
    11231123               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    11331133               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    11341134               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) ) 
    11361136               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    11371137               l_1st_euler = .true. 
    … …  
    11401140               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    11411141               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) ) 
    11431143               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    11441144               l_1st_euler = .true. 
    … …  
    11651165               !                          ! ----------------------- ! 
    11661166               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(:,:,:) ) 
    11691169               ELSE                            ! one at least array is missing 
    11701170                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    11751175                  !                       ! ------------ ! 
    11761176                  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(:,:,:) ) 
    11781178                  ELSE                ! array is missing 
    11791179                     hdiv_lf(:,:,:) = 0.0_wp 
    … …  
    12511251         !                                   ! =================== 
    12521252         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    1253          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    12541253         !                                           ! --------- ! 
    12551254         !                                           ! all cases ! 
    12561255         !                                           ! --------- ! 
    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) ) 
    12591258         !                                           ! ----------------------- ! 
    12601259         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    12611260            !                                        ! ----------------------- ! 
    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(:,:,:)) 
    12641263         END IF 
    12651264         !                                           ! -------------!     
    12661265         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    12671266            !                                        ! ------------ ! 
    1268             CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) 
     1267            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 
    12691268         ENDIF 
    12701269         ! 
    1271          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    12721270      ENDIF 
    12731271      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/nemogcm.F90

    r12983 r13992  
    383383                           CALL     phy_cst         ! Physical constants 
    384384                            
    385                            CALL     dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 
     385                           CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    386386 
    387387      IF( sn_cfctl%l_prtctl )   & 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/step.F90

    r13458 r13992  
    304304      IF( kstp == nitend .OR. indic < 0 ) THEN  
    305305                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    306                       IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     306                      IF(lrxios) CALL iom_context_finalize(      cr_ocerst_cxt          ) 
    307307      ENDIF 
    308308#endif 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/stepLF.F90

    r13295 r13992  
    318318      IF( kstp == nitend .OR. indic < 0 ) THEN  
    319319                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    320                       IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     320                      IF(lrxios) CALL iom_context_finalize(      cr_ocerst_cxt          ) 
    321321      ENDIF 
    322322#endif 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/SWE/stpRK3.F90

    r13295 r13992  
    361361      IF( kstp == nitend .OR. indic < 0 ) THEN  
    362362                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    363                       IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     363                      IF(lrxios) CALL iom_context_finalize(      cr_ocerst_cxt          ) 
    364364      ENDIF 
    365365#endif 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/C14/trcsms_c14.F90

    r13295 r13992  
    144144         IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
    145145         ! 
    146          CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc )       ! These five need      & 
    147          CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc )     ! &    to be written   & 
     146         CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) ! These five need      & 
     147         CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) ! &    to be written   & 
    148148         CALL iom_rstput( kt, nitrst, numrtw, 'exch_co2', exch_co2 ) ! &    for temporal    & 
    149149         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. 
    151151         CALL iom_rstput( kt, nitrst, numrtw, 'qint_c14', qint_c14 ) ! Cumulative 
    152152         ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/PISCES/P4Z/p4zsms.F90

    r13472 r13992  
    369369            IF(lwp) WRITE(numout,*) '~~~~~~~' 
    370370         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(:,:)    ) 
    373373         CALL iom_rstput( kt, nitrst, numrtw, 'Silicamax', xksimax(:,:) ) 
    374374         CALL iom_rstput( kt, nitrst, numrtw, 'tcflxcum', t_oce_co2_flx_cum ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/PISCES/SED/sed.F90

    r10425 r13992  
    4444   REAL    , PUBLIC               ::  sedmask 
    4545   REAL(wp), PUBLIC               ::  denssol                !: density of solid material 
    46    INTEGER , PUBLIC               ::  numrsr, numrsw   !: logical unit for sed restart (read and write) 
    4746   LOGICAL , PUBLIC               ::  lrst_sed       !: logical to control the trc restart write 
    4847   LOGICAL , PUBLIC               ::  ln_rst_sed  = .TRUE.     !: initialisation from a restart file or not 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/PISCES/SED/sedrst.F90

    r13286 r13992  
    4242      CHARACTER(LEN=50)   ::   clname   ! trc output restart file name 
    4343      CHARACTER(LEN=256)  ::   clpath   ! full path to ocean output restart file 
     44      CHARACTER(LEN=52)   ::   clpname   ! trc output restart file name including AGRIF 
    4445      !!---------------------------------------------------------------------- 
    4546      ! 
    … …  
    8081         IF(lwp) WRITE(numsed,*) & 
    8182             '             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 
    83101         lrst_sed = .TRUE. 
    84102      ENDIF 
    … …  
    196214      CALL pack_arr( jpoce, sedligand(1:jpoce,1:jpksed), & 
    197215         &             zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) 
    198  
    199216      IF( ln_timing )  CALL timing_stop('sed_rst_read') 
    200217      
    … …  
    240257      !! 1. WRITE in nutwrs 
    241258      !! ------------------ 
    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) ) 
    245261 
    246262      ! Back to 2D geometry 
    … …  
    299315 
    300316      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 
    302324          IF( l_offline .AND. ln_rst_list ) THEN 
    303325             nrst_lst = nrst_lst + 1 
    … …  
    342364      REAL(wp) ::  zkt, zrdttrc1 
    343365      REAL(wp) ::  zndastp 
     366      CHARACTER(len = 82) :: clpname 
    344367 
    345368      ! Time domain : restart 
    … …  
    353376 
    354377         IF( ln_rst_sed ) THEN 
     378            lxios_sini = .FALSE. 
    355379            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 
    356391            CALL iom_get ( numrsr, 'kt', zkt )   ! last time-step of previous run 
    357  
    358392            IF(lwp) THEN 
    359393               WRITE(numsed,*) ' *** Info read in restart : ' 
    … …  
    402436            IF(lwp) WRITE(numsed,*) 'trc_wri : write the TOP restart file (NetCDF) at it= ', kt, ' date= ', ndastp 
    403437            IF(lwp) WRITE(numsed,*) '~~~~~~~' 
     438            IF( lwxios ) CALL iom_init_closedef(cw_sedrst_cxt) 
    404439         ENDIF 
    405440         CALL iom_rstput( kt, nitrst, numrsw, 'kt'     , REAL( kt    , wp) )   ! time-step 
    406441         CALL iom_rstput( kt, nitrst, numrsw, 'ndastp' , REAL( ndastp, wp) )   ! date 
    407          CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj            )   ! number of elapsed days since 
    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] 
    409444      ENDIF 
    410445 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/PISCES/SED/sedstp.F90

    r12489 r13992  
    8686      IF( kt == nitsed000 ) THEN 
    8787          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 
    8990      ENDIF 
    9091      IF( lrst_sed )            CALL sed_rst_wri( kt )   ! restart file output 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/TRP/trcadv.F90

    r13286 r13992  
    2222   USE traadv_cen     ! centered scheme           (tra_adv_cen  routine) 
    2323   USE traadv_fct     ! FCT      scheme           (tra_adv_fct  routine) 
     24   USE traadv_fct_lf  ! FCT      scheme           (tra_adv_fct  routine - loop fusion version) 
    2425   USE traadv_mus     ! MUSCL    scheme           (tra_adv_mus  routine) 
     26   USE traadv_mus_lf  ! MUSCL    scheme           (tra_adv_mus  routine - loop fusion version) 
    2527   USE traadv_ubs     ! UBS      scheme           (tra_adv_ubs  routine) 
    2628   USE traadv_qck     ! QUICKEST scheme           (tra_adv_qck  routine) 
    … …  
    124126      ! 
    125127      CASE ( np_CEN )                                 ! Centered : 2nd / 4th order 
     128         IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kmm), 'T', 1.) 
    126129         CALL tra_adv_cen( kt, nittrc000,'TRC',          zuu, zvv, zww,      Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v ) 
    127130      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 
    129142      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 
    131153      CASE ( np_UBS )                                 ! UBS 
     154         IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 
    132155         CALL tra_adv_ubs( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v           ) 
    133156      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 
    134161         CALL tra_adv_qck( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs                     ) 
    135162      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/TRP/trcldf.F90

    r13295 r13992  
    101101           &                     ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 ) 
    102102      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.) 
    103104         CALL tra_ldf_blp  ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi,            & 
    104105           &                     ptr(:,:,:,:,Kbb) , ptr(:,:,:,:,Krhs),                 jptra, nldf_trc ) 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/trc.F90

    r13558 r13992  
    2121   INTEGER, PUBLIC ::   numonr     = -1   !: reference passive tracer namelist output output.namelist.top 
    2222   INTEGER, PUBLIC ::   numstr            !: tracer statistics 
    23    INTEGER, PUBLIC ::   numrtr     = -1   !: trc restart (read ) 
    24    INTEGER, PUBLIC ::   numrtw            !: trc restart ( write ) 
    2523   CHARACTER(:), ALLOCATABLE, PUBLIC ::   numnat_ref   !: character buffer for reference passive tracer namelist_top_ref 
    2624   CHARACTER(:), ALLOCATABLE, PUBLIC ::   numnat_cfg   !: character buffer for configuration specific passive tracer namelist_top_cfg 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/trcrst.F90

    r13558 r13992  
    5252      CHARACTER(LEN=50)   ::   clname   ! trc output restart file name 
    5353      CHARACTER(LEN=256)  ::   clpath   ! full path to ocean output restart file 
     54      CHARACTER(LEN=50)   ::   clpname  ! trc output restart file name including AGRIF 
    5455      !!---------------------------------------------------------------------- 
    5556      ! 
    … …  
    9192         IF(lwp) WRITE(numout,*) & 
    9293             '             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 
    94111         lrst_trc = .TRUE. 
    95112      ENDIF 
    … …  
    121138      END DO 
    122139      ! 
    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 
    125141   END SUBROUTINE trc_rst_read 
    126142 
    … …  
    147163         CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) ) 
    148164      END DO 
    149       ! 
    150       CALL iom_delay_rst( 'WRITE', 'TOP', numrtw )   ! save only TOP delayed global communication variables 
     165 
     166      IF( .NOT. lwxios ) CALL iom_delay_rst( 'WRITE', 'TOP', numrtw )   ! save only TOP delayed global communication variables 
    151167     
    152168      IF( kt == nitrst ) THEN 
    153169          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 
    155177#if ! defined key_trdmxl_trc 
    156178          lrst_trc = .FALSE. 
    … …  
    196218      REAL(wp) ::  zrdttrc1, zkt, zndastp, zdayfrac, ksecs, ktime 
    197219      INTEGER  ::   ihour, iminute 
     220      CHARACTER(len=82) :: clpname 
    198221 
    199222      ! Time domain : restart 
    … …  
    207230 
    208231         IF( ln_rsttr ) THEN 
     232            lxios_sini = .FALSE. 
    209233            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 
    210245            CALL iom_get ( numrtr, 'kt', zkt )   ! last time-step of previous run 
    211246 
    … …  
    293328            IF(lwp) WRITE(numout,*) '~~~~~~~' 
    294329         ENDIF 
    295          CALL iom_rstput( kt, nitrst, numrtw, 'kt'     , REAL( kt    , wp) )   ! time-step 
    296          CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) )   ! date 
    297          CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj            )   ! number of elapsed days since 
     330         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 
    298333         !                                                                     ! the begining of the run [s] 
    299          CALL iom_rstput( kt, nitrst, numrtw, 'ntime'  , REAL( nn_time0, wp)) ! time 
     334         CALL iom_rstput( kt, nitrst, numrtw, 'ntime'  , REAL( nn_time0, wp) ) ! time 
    300335      ENDIF 
    301336 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/src/TOP/trcstp.F90

    r13286 r13992  
    110110      IF( kt == nittrc000 ) THEN 
    111111         CALL iom_close( numrtr )                         ! close input tracer restart file 
     112         IF(lrxios) CALL iom_context_finalize(      cr_toprst_cxt          ) 
    112113         IF(lwm) CALL FLUSH( numont )                     ! flush namelist output 
    113114      ENDIF 
    … …  
    196197           &                              .AND. iom_varid( numrtr, 'ktdcy'    , ldstop = .FALSE. ) > 0  & 
    197198           &                              .AND. iom_varid( numrtr, 'nrdcy'    , ldstop = .FALSE. ) > 0  ) THEN 
    198  
    199199            CALL iom_get( numrtr, 'ktdcy', zkt )   
    200200            rsecfst = INT( zkt ) * rn_Dt 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/CANAL/MY_SRC/domvvl.F90

    r13458 r13992  
    282282      ENDIF 
    283283      ! 
    284       IF(lwxios) THEN 
    285 ! define variables in restart file when writing with XIOS 
    286          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 IF 
    294          !                                           ! -------------!     
    295          IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    296             !                                        ! ------------ ! 
    297             CALL iom_set_rstw_var_active('hdiv_lf') 
    298          ENDIF 
    299          ! 
    300       ENDIF 
    301       ! 
    302284   END SUBROUTINE dom_vvl_zgr 
    303285 
    … …  
    803785         IF( ln_rstart ) THEN                   !* Read the restart file 
    804786            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)    ) 
    806788            ! 
    807789            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    816798            ! 
    817799            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) ) 
    820802               ! needed to restart if land processor not computed  
    821803               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    831813               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    832814               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) ) 
    834816               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    835817               l_1st_euler = .true. 
    … …  
    838820               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    839821               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) ) 
    841823               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    842824               l_1st_euler = .true. 
    … …  
    863845               !                          ! ----------------------- ! 
    864846               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(:,:,:) ) 
    867849               ELSE                            ! one at least array is missing 
    868850                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    873855                  !                       ! ------------ ! 
    874856                  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(:,:,:) ) 
    876858                  ELSE                ! array is missing 
    877859                     hdiv_lf(:,:,:) = 0.0_wp 
    … …  
    947929         !                                   ! =================== 
    948930         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    949          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    950931         !                                           ! --------- ! 
    951932         !                                           ! all cases ! 
    952933         !                                           ! --------- ! 
    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) ) 
    955936         !                                           ! ----------------------- ! 
    956937         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    957938            !                                        ! ----------------------- ! 
    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(:,:,:)) 
    960941         END IF 
    961942         !                                           ! -------------!     
    962943         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    963944            !                                        ! ------------ ! 
    964             CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) 
     945            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 
    965946         ENDIF 
    966947         ! 
    967          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    968948      ENDIF 
    969949      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/CANAL/MY_SRC/trazdf.F90

    r13295 r13992  
    5454      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5555      ! 
    56       INTEGER  ::   jk   ! Dummy loop indices 
     56      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    5757      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    5858      !!--------------------------------------------------------------------- 
    … …  
    6161      ! 
    6262      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 
    6668      ENDIF 
    6769      ! 
    … …  
    8385 
    8486      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) 
    9096         END DO 
    9197!!gm this should be moved in trdtra.F90 and done on all trends 
    … …  
    135141      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    136142      REAL(wp) ::  zrhs, zzwi, zzws ! local scalars 
    137       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws 
     143      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::  zwi, zwt, zwd, zws 
    138144      !!--------------------------------------------------------------------- 
    139145      ! 
    … …  
    149155            ! 
    150156            ! 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 
    153165            ENDIF 
    154166            zwt(:,:,1) = 0._wp 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/ISOMIP+/MY_SRC/dtatsd.F90

    r13583 r13992  
    1818   USE phycst          ! physical constants 
    1919   USE dom_oce         ! ocean space and time domain 
     20   USE domain, ONLY : dom_tile 
    2021   USE fldread         ! read input fields 
    2122   ! 
    … …  
    163164      INTEGER                              , INTENT(in   ) ::   kt     ! ocean time-step 
    164165      CHARACTER(LEN=3)                     , INTENT(in   ) ::   cddta  ! dmp or ini 
    165       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
     166      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
    166167      ! 
    167168      INTEGER ::   ji, jj, jk, jl, jkk   ! dummy loop indicies 
    168169      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers 
     170      INTEGER ::   itile 
    169171      REAL(wp)::   zl, zi                             ! local scalars 
    170172      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace 
    171173      !!---------------------------------------------------------------------- 
    172174      ! 
     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      ! 
    173191      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 
    178197      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 
    182202      CASE DEFAULT 
    183203         CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') 
    … …  
    186206      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    187207         ! 
    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 
    191213         ENDIF 
    192214         ! 
    … …  
    220242      ELSE                                !==   z- or zps- coordinate   ==! 
    221243         !                              
    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 
    224248         ! 
    225249         IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/ISOMIP+/MY_SRC/eosbn2.F90

    r13888 r13992  
    3939   !!---------------------------------------------------------------------- 
    4040   USE dom_oce        ! ocean space and time domain 
     41   USE domutl, ONLY : is_tile 
    4142   USE phycst         ! physical constants 
    4243   USE stopar         ! Stochastic T/S fluctuations 
    … …  
    191192 
    192193   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 ) 
    193204      !!---------------------------------------------------------------------- 
    194205      !!                   ***  ROUTINE eos_insitu  *** 
    … …  
    228239      !!                TEOS-10 Manual, 2010 
    229240      !!---------------------------------------------------------------------- 
    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] 
    231243      !                                                               ! 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] 
    234246      ! 
    235247      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    312324      IF( ln_timing )   CALL timing_stop('eos-insitu') 
    313325      ! 
    314    END SUBROUTINE eos_insitu 
     326   END SUBROUTINE eos_insitu_t 
    315327 
    316328 
    317329   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 ) 
    318342      !!---------------------------------------------------------------------- 
    319343      !!                  ***  ROUTINE eos_insitu_pot  *** 
    … …  
    328352      !! 
    329353      !!---------------------------------------------------------------------- 
    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] 
    331356      !                                                                ! 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] 
    335360      ! 
    336361      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    … …  
    482507      IF( ln_timing )   CALL timing_stop('eos-pot') 
    483508      ! 
    484    END SUBROUTINE eos_insitu_pot 
     509   END SUBROUTINE eos_insitu_pot_t 
    485510 
    486511 
    487512   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 ) 
    488524      !!---------------------------------------------------------------------- 
    489525      !!                  ***  ROUTINE eos_insitu_2d  *** 
    … …  
    496532      !! 
    497533      !!---------------------------------------------------------------------- 
    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] 
    499536      !                                                           ! 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 density 
     537      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     538      REAL(wp), DIMENSION(A2D_T(ktrd)     ), INTENT(  out) ::   prd   ! in situ density 
    502539      ! 
    503540      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    584621      IF( ln_timing )   CALL timing_stop('eos2d') 
    585622      ! 
    586    END SUBROUTINE eos_insitu_2d 
     623   END SUBROUTINE eos_insitu_2d_t 
    587624 
    588625 
    … …  
    674711 
    675712   SUBROUTINE rab_3d( pts, pab, Kmm ) 
     713      !! 
     714      INTEGER                     , INTENT(in   ) ::   Kmm   ! time level index 
     715      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     716      REAL(wp), DIMENSION(:,:,:,:), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     717      !! 
     718      CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 
     719   END SUBROUTINE rab_3d 
     720 
     721 
     722   SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 
    676723      !!---------------------------------------------------------------------- 
    677724      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    684731      !!---------------------------------------------------------------------- 
    685732      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    686       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
    687       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     733      INTEGER                                , INTENT(in   ) ::   ktts, ktab 
     734      REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     735      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    688736      ! 
    689737      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    792840      IF( ln_timing )   CALL timing_stop('rab_3d') 
    793841      ! 
    794    END SUBROUTINE rab_3d 
     842   END SUBROUTINE rab_3d_t 
    795843 
    796844 
    797845   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
     846      !! 
     847      INTEGER                   , INTENT(in   ) ::   Kmm   ! time level index 
     848      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     849      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep   ! depth                  [m] 
     850      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     851      !! 
     852      CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 
     853   END SUBROUTINE rab_2d 
     854 
     855 
     856   SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 
    798857      !!---------------------------------------------------------------------- 
    799858      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    804863      !!---------------------------------------------------------------------- 
    805864      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    806       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    807       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
    808       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     865      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktab 
     866      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     867      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep   ! depth                  [m] 
     868      REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
    809869      ! 
    810870      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    915975      IF( ln_timing )   CALL timing_stop('rab_2d') 
    916976      ! 
    917    END SUBROUTINE rab_2d 
     977   END SUBROUTINE rab_2d_t 
    918978 
    919979 
    … …  
    10281088 
    10291089   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
     1090      !! 
     1091      INTEGER                              , INTENT(in   ) ::  Kmm   ! time level index 
     1092      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     1093      REAL(wp), DIMENSION(:,:,:,:)         , INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1094      REAL(wp), DIMENSION(:,:,:)           , INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     1095      !! 
     1096      CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 
     1097   END SUBROUTINE bn2 
     1098 
     1099 
     1100   SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 
    10301101      !!---------------------------------------------------------------------- 
    10311102      !!                  ***  ROUTINE bn2  *** 
    … …  
    10421113      !!---------------------------------------------------------------------- 
    10431114      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
     1115      INTEGER                                , INTENT(in   ) ::  ktab, ktn2 
    10441116      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
    1045       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
    1046       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     1117      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1118      REAL(wp), DIMENSION(A2D_T(ktn2),JPK     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    10471119      ! 
    10481120      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    10681140      IF( ln_timing )   CALL timing_stop('bn2') 
    10691141      ! 
    1070    END SUBROUTINE bn2 
     1142   END SUBROUTINE bn2_t 
    10711143 
    10721144 
    … …  
    11291201 
    11301202   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     1203      !! 
     1204      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1205      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1206      REAL(wp), DIMENSION(:,:)    , INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1207      !! 
     1208      CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 
     1209   END SUBROUTINE eos_fzp_2d 
     1210 
     1211 
     1212   SUBROUTINE  eos_fzp_2d_t( psal, ptf, kttf, pdep ) 
    11311213      !!---------------------------------------------------------------------- 
    11321214      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    11401222      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    11411223      !!---------------------------------------------------------------------- 
     1224      INTEGER                       , INTENT(in   )           ::   kttf 
    11421225      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    11431226      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1144       REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1227      REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
    11451228      ! 
    11461229      INTEGER  ::   ji, jj          ! dummy loop indices 
    … …  
    11751258      END SELECT       
    11761259      ! 
    1177   END SUBROUTINE eos_fzp_2d 
     1260  END SUBROUTINE eos_fzp_2d_t 
    11781261 
    11791262 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/ISOMIP+/MY_SRC/tradmp.F90

    r13295 r13992  
    9595      ! 
    9696      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    97       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)     ::  zts_dta 
     97      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts)     ::  zts_dta 
    9898      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  ztrdts 
    9999      !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/VORTEX/MY_SRC/domvvl.F90

    r13458 r13992  
    282282      ENDIF 
    283283      ! 
    284       IF(lwxios) THEN 
    285 ! define variables in restart file when writing with XIOS 
    286          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 IF 
    294          !                                           ! -------------!     
    295          IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    296             !                                        ! ------------ ! 
    297             CALL iom_set_rstw_var_active('hdiv_lf') 
    298          ENDIF 
    299          ! 
    300       ENDIF 
    301       ! 
    302284   END SUBROUTINE dom_vvl_zgr 
    303285 
    … …  
    803785         IF( ln_rstart ) THEN                   !* Read the restart file 
    804786            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)    ) 
    806788            ! 
    807789            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    816798            ! 
    817799            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) ) 
    820802               ! needed to restart if land processor not computed  
    821803               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    831813               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    832814               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) ) 
    834816               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    835817               l_1st_euler = .true. 
    … …  
    838820               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    839821               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) ) 
    841823               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    842824               l_1st_euler = .true. 
    … …  
    863845               !                          ! ----------------------- ! 
    864846               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(:,:,:) ) 
    867849               ELSE                            ! one at least array is missing 
    868850                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    873855                  !                       ! ------------ ! 
    874856                  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(:,:,:) ) 
    876858                  ELSE                ! array is missing 
    877859                     hdiv_lf(:,:,:) = 0.0_wp 
    … …  
    947929         !                                   ! =================== 
    948930         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    949          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    950931         !                                           ! --------- ! 
    951932         !                                           ! all cases ! 
    952933         !                                           ! --------- ! 
    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) ) 
    955936         !                                           ! ----------------------- ! 
    956937         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    957938            !                                        ! ----------------------- ! 
    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(:,:,:)) 
    960941         END IF 
    961942         !                                           ! -------------!     
    962943         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    963944            !                                        ! ------------ ! 
    964             CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) 
     945            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 
    965946         ENDIF 
    966947         ! 
    967          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    968948      ENDIF 
    969949      ! 

  • NEMO/branches/2020/dev_r2052_ENHANCE-09_rbourdal_massfluxconvection/tests/demo_cfgs.txt

    r13207 r13992  
    1212STATION_ASF OCE 
    1313CPL_OASIS  OCE TOP ICE NST 
     14C1D_ASICS OCE 
Note: See TracChangeset for help on using the changeset viewer.