From 3295218365ad6615e0c3d77b8eec424950794d64 Mon Sep 17 00:00:00 2001 From: Adam Tobias Blaker Date: Mon, 12 Jun 2023 12:07:33 +0100 Subject: [PATCH] Added MY_SRC changes for reset_ts etc. plus missing links to INPUT files --- TMP_MY_SRC/diawri.F90 | 1254 ++++++++ TMP_MY_SRC/domain.F90 | 805 +++++ TMP_MY_SRC/domzgr.F90 | 323 ++ TMP_MY_SRC/dtatsd.F90 | 281 ++ TMP_MY_SRC/in_out_manager.F90 | 195 ++ TMP_MY_SRC/iom.F90 | 2858 +++++++++++++++++ TMP_MY_SRC/istate.F90 | 192 ++ TMP_MY_SRC/ldftra.F90 | 976 ++++++ cfgs/GLOBAL_QCO/MY_SRC/diawri.F90 | 2 +- cfgs/GLOBAL_QCO/MY_SRC/domain.F90 | 47 +- cfgs/GLOBAL_QCO/MY_SRC/domzgr.F90 | 237 +- cfgs/GLOBAL_QCO/MY_SRC/dtatsd.F90 | 6 +- cfgs/GLOBAL_QCO/MY_SRC/iom.F90 | 527 ++- cfgs/GLOBAL_QCO/MY_SRC/istate.F90 | 47 +- cfgs/GLOBAL_QCO/MY_SRC/ldftra.F90 | 27 +- cfgs/GLOBAL_QCO/cpp_GLOBAL_QCO.fcm | 2 +- cfgs/SHARED/field_def_nemo-oce.xml | 4 + cfgs/SHARED/namelist_ref | 2 - data/INPUT_eORCA025_Anemone/bfr_coef.nc | 1 + data/INPUT_eORCA025_Anemone/domcfg.nc | 1 + data/INPUT_eORCA025_Anemone/domcfg.nc_newDS | 1 + ...hermal_heating_orca025ext_extrap40_v4.2.nc | 1 + scripts/setup | 14 +- 23 files changed, 7353 insertions(+), 450 deletions(-) create mode 100644 TMP_MY_SRC/diawri.F90 create mode 100644 TMP_MY_SRC/domain.F90 create mode 100644 TMP_MY_SRC/domzgr.F90 create mode 100644 TMP_MY_SRC/dtatsd.F90 create mode 100644 TMP_MY_SRC/in_out_manager.F90 create mode 100644 TMP_MY_SRC/iom.F90 create mode 100644 TMP_MY_SRC/istate.F90 create mode 100644 TMP_MY_SRC/ldftra.F90 create mode 120000 data/INPUT_eORCA025_Anemone/bfr_coef.nc create mode 120000 data/INPUT_eORCA025_Anemone/domcfg.nc create mode 120000 data/INPUT_eORCA025_Anemone/domcfg.nc_newDS create mode 120000 data/INPUT_eORCA025_Anemone/geothermal_heating_orca025ext_extrap40_v4.2.nc diff --git a/TMP_MY_SRC/diawri.F90 b/TMP_MY_SRC/diawri.F90 new file mode 100644 index 0000000..a6d3717 --- /dev/null +++ b/TMP_MY_SRC/diawri.F90 @@ -0,0 +1,1254 @@ +MODULE diawri + !!====================================================================== + !! *** MODULE diawri *** + !! Ocean diagnostics : write ocean output files + !!===================================================================== + !! History : OPA ! 1991-03 (M.-A. Foujols) Original code + !! 4.0 ! 1991-11 (G. Madec) + !! ! 1992-06 (M. Imbard) correction restart file + !! ! 1992-07 (M. Imbard) split into diawri and rstwri + !! ! 1993-03 (M. Imbard) suppress writibm + !! ! 1998-01 (C. Levy) NETCDF format using ioipsl INTERFACE + !! ! 1999-02 (E. Guilyardi) name of netCDF files + variables + !! 8.2 ! 2000-06 (M. Imbard) Original code (diabort.F) + !! NEMO 1.0 ! 2002-06 (A.Bozec, E. Durand) Original code (diainit.F) + !! - ! 2002-09 (G. Madec) F90: Free form and module + !! - ! 2002-12 (G. Madec) merge of diabort and diainit, F90 + !! ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2008-11 (B. Lemaire) creation from old diawri + !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output + !! ! change name of output variables in dia_wri_state + !! 4.0 ! 2020-10 (A. Nasser, S. Techene) add diagnostic for SWE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_wri : create the standart output files + !! dia_wri_state : create an output NetCDF file for a single instantaeous ocean state and forcing fields + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce + USE isfcpl + USE abl ! abl variables in case ln_abl = .true. + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE dianam ! build name of file (routine) + USE diahth ! thermocline diagnostics + USE dynadv , ONLY: ln_dynadv_vec + USE icb_oce ! Icebergs + USE icbdia ! Iceberg budgets + USE ldftra ! lateral physics: eddy diffusivity coef. + USE ldfdyn ! lateral physics: eddy viscosity coef. + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcssr ! restoring term toward SST/SSS climatology + USE sbcwave ! wave parameters + USE wet_dry ! wetting and drying + USE zdf_oce ! ocean vertical physics + USE zdfdrg ! ocean vertical physics: top/bottom friction + USE zdfmxl ! mixed layer + USE zdfosm ! mixed layer + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE dia25h ! 25h Mean output + USE iom ! + USE ioipsl ! + +#if defined key_si3 + USE ice + USE icewri +#endif + USE lib_mpp ! MPP library + USE timing ! preformance summary + USE diu_bulk ! diurnal warm layer + USE diu_coolskin ! Cool skin + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_wri ! routines called by step.F90 + PUBLIC dia_wri_state + PUBLIC dia_wri_alloc ! Called by nemogcm module +#if ! defined key_xios + PUBLIC dia_wri_alloc_abl ! Called by sbcabl module (if ln_abl = .true.) +#endif + INTEGER :: nid_T, nz_T, nh_T, ndim_T, ndim_hT ! grid_T file + INTEGER :: nb_T , ndim_bT ! grid_T file + INTEGER :: nid_U, nz_U, nh_U, ndim_U, ndim_hU ! grid_U file + INTEGER :: nid_V, nz_V, nh_V, ndim_V, ndim_hV ! grid_V file + INTEGER :: nid_W, nz_W, nh_W ! grid_W file + INTEGER :: nid_A, nz_A, nh_A, ndim_A, ndim_hA ! grid_ABL file + INTEGER :: ndex(1) ! ??? + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hA, ndex_A ! ABL + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diawri.F90 15141 2021-07-23 14:20:12Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_xios + !!---------------------------------------------------------------------- + !! 'key_xios' use IOM library + !!---------------------------------------------------------------------- + INTEGER FUNCTION dia_wri_alloc() + ! + dia_wri_alloc = 0 + ! + END FUNCTION dia_wri_alloc + + + SUBROUTINE dia_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri *** + !! + !! ** Purpose : Standard output of opa: dynamics and tracer fields + !! NETCDF format is used by default + !! + !! ** Method : use iom_put + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbot ! local integer + REAL(wp):: zztmp , zztmpx ! local scalar + REAL(wp):: zztmp2, zztmpy ! - - + REAL(wp):: ze3 + REAL(wp), DIMENSION(A2D( 0)) :: z2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z3d ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! Output the initial state and forcings + IF( ninist == 1 ) THEN + CALL dia_wri_state( Kmm, 'output.init' ) + ninist = 0 + ENDIF + + ! initialize arrays + z2d(:,:) = 0._wp + z3d(:,:,:) = 0._wp + + ! Output of initial vertical scale factor + CALL iom_put("e3t_0", e3t_0(:,:,:) ) + CALL iom_put("e3u_0", e3u_0(:,:,:) ) + CALL iom_put("e3v_0", e3v_0(:,:,:) ) + CALL iom_put("e3f_0", e3f_0(:,:,:) ) + ! + IF ( iom_use("tpt_dep") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "tpt_dep", z3d ) + ENDIF + + ! --- vertical scale factors --- ! + IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3t", z3d ) + IF ( iom_use("e3tdef") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ( ( z3d(ji,jj,jk) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2 + END_3D + CALL iom_put( "e3tdef", z3d ) + ENDIF + ENDIF + IF ( iom_use("e3u") ) THEN ! time-varying e3u + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3u(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3u" , z3d ) + ENDIF + IF ( iom_use("e3v") ) THEN ! time-varying e3v + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3v(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3v" , z3d ) + ENDIF + IF ( iom_use("e3w") ) THEN ! time-varying e3w + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3w(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3w" , z3d ) + ENDIF + IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3f(ji,jj,jk) + END_3D + CALL iom_put( "e3f" , z3d ) + ENDIF + + IF ( iom_use("ssh") ) THEN + IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying) + CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*ssmask(:,:) ) + ELSE + CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height + ENDIF + ENDIF + + IF( iom_use("wetdep") ) CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) ! wet depth + +#if defined key_qco + IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:) ) ! water column at t-point + IF( iom_use("hu") ) CALL iom_put( "hu" , hu(:,:,Kmm) ) ! water column at u-point + IF( iom_use("hv") ) CALL iom_put( "hv" , hv(:,:,Kmm) ) ! water column at v-point + IF( iom_use("hf") ) CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) ) ! water column at f-point (caution here at Naa) +#endif + + ! --- tracers T&S --- ! + CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) ) ! 3D temperature + CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature + + IF ( iom_use("sbt") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) + END_2D + CALL iom_put( "sbt", z2d ) ! bottom temperature + ENDIF + + CALL iom_put( "soce", ts(:,:,:,jp_sal,Kmm) ) ! 3D salinity + CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity + IF ( iom_use("sbs") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) + END_2D + CALL iom_put( "sbs", z2d ) ! bottom salinity + ENDIF + + IF( .NOT.lk_SWE ) CALL iom_put( "rhop", rhop(:,:,:) ) ! 3D potential density (sigma0) + + ! --- momentum --- ! + IF ( iom_use("taubot") ) THEN ! bottom stress + zztmp = rho0 * 0.25_wp + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * uu(ji ,jj,mbku(ji ,jj),Kmm) )**2 & + & + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * uu(ji-1,jj,mbku(ji-1,jj),Kmm) )**2 & + & + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vv(ji,jj ,mbkv(ji,jj ),Kmm) )**2 & + & + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vv(ji,jj-1,mbkv(ji,jj-1),Kmm) )**2 + z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) + ! + END_2D + CALL iom_put( "taubot", z2d ) + ENDIF + + CALL iom_put( "uoce", uu(:,:,:,Kmm) ) ! 3D i-current + CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current + IF ( iom_use("sbu") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbku(ji,jj) + z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) + END_2D + CALL iom_put( "sbu", z2d ) ! bottom i-current + ENDIF + + CALL iom_put( "voce", vv(:,:,:,Kmm) ) ! 3D j-current + CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current + IF ( iom_use("sbv") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkv(ji,jj) + z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) + END_2D + CALL iom_put( "sbv", z2d ) ! bottom j-current + ENDIF + + ! ! vertical velocity + IF( ln_zad_Aimp ) THEN + IF( iom_use('woce') ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL iom_put( "woce", z3d ) ! explicit plus implicit parts + ENDIF + ELSE + CALL iom_put( "woce", ww ) + ENDIF + + IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value + ! ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wi(ji,jj,jk) ) + END_3D + ELSE + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ww(ji,jj,jk) + END_3D + ENDIF + CALL iom_put( "w_masstr" , z3d ) + IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d * z3d ) + ENDIF + + CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. + CALL iom_put( "avs" , avs ) ! S vert. eddy diff. coef. + CALL iom_put( "avm" , avm ) ! T vert. eddy visc. coef. + + IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt(:,:,:) ) ) ) + IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) + + IF ( iom_use("sssgrad") .OR. iom_use("sssgrad2") ) THEN + DO_2D( 0, 0, 0, 0 ) ! sss gradient + zztmp = ts(ji,jj,1,jp_sal,Kmm) + zztmpx = (ts(ji+1,jj,1,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,1,jp_sal,Kmm)) * r1_e1u(ji-1,jj) + zztmpy = (ts(ji,jj+1,1,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,1,jp_sal,Kmm)) * r1_e2v(ji,jj-1) + z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1) + END_2D + CALL iom_put( "sssgrad2", z2d ) ! square of module of sss gradient + IF ( iom_use("sssgrad") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END_2D + CALL iom_put( "sssgrad", z2d ) ! module of sss gradient + ENDIF + ENDIF + + IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN + DO_2D( 0, 0, 0, 0 ) ! sst gradient + zztmp = ts(ji,jj,1,jp_tem,Kmm) + zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj) + zztmpy = ( ts(ji,jj+1,1,jp_tem,Kmm) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - ts(ji ,jj-1,1,jp_tem,Kmm) ) * r1_e2v(ji,jj-1) + z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1) + END_2D + CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient + IF ( iom_use("sstgrad") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END_2D + CALL iom_put( "sstgrad", z2d ) ! module of sst gradient + ENDIF + ENDIF + + ! heat and salt contents + IF( iom_use("heatc") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "heatc", rho0_rcp * z2d ) ! vertically integrated heat content (J/m2) + ENDIF + + IF( iom_use("saltc") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "saltc", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) + ENDIF + ! + IF( iom_use("salt2c") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated square of salt content (PSU2*kg/m2) + ENDIF + ! + IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zztmpx = uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) + zztmpy = vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) + z3d(ji,jj,jk) = 0.25_wp * ( zztmpx*zztmpx + zztmpy*zztmpy ) + END_3D + CALL iom_put( "ke", z3d ) ! kinetic energy + + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy + ENDIF + ! + IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) & + & + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm) & + & + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,1,Kmm) & + & + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj) + END_2D + IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d ) + ENDIF + ! + IF ( iom_use("ssKEf") ) THEN ! surface kinetic energy at F point + z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) & + & + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm) & + & + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * e3v(ji ,jj,1,Kmm) & + & + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm) ) & + & * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj) + END_2D + CALL iom_put( "ssKEf", z2d ) + ENDIF + ! + CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence + ! + IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN + + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * uu(ji,jj,jk,Kmm) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) + END_3D + CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction + + IF( iom_use("u_masstr_vint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) + END_3D + CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum + ENDIF + IF( iom_use("u_heattr") ) THEN + z2d(:,:) = 0._wp + zztmp = 0.5_wp * rcp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) + END_3D + CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction + ENDIF + IF( iom_use("u_salttr") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) + END_3D + CALL iom_put( "u_salttr", z2d ) ! heat transport in i-direction + ENDIF + + ENDIF + + IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN + + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * vv(ji,jj,jk,Kmm) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + END_3D + CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction + + IF( iom_use("v_heattr") ) THEN + z2d(:,:) = 0._wp + zztmp = 0.5_wp * rcp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) + END_3D + CALL iom_put( "v_heattr", z2d ) ! heat transport in j-direction + ENDIF + IF( iom_use("v_salttr") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) + END_3D + CALL iom_put( "v_salttr", z2d ) ! heat transport in j-direction + ENDIF + + ENDIF + + IF( (.NOT.l_ldfeiv_time) .AND. ( iom_use('RossRad') .OR. iom_use('RossRadlim') & + & .OR. iom_use('Tclinic_recip') .OR. iom_use('RR_GS') & + & .OR. iom_use('aeiu_2d') .OR. iom_use('aeiv_2d') ) ) THEN + CALL ldf_eiv(kt, 75.0, z2d, z3d(:,:,1), Kmm) + CALL iom_put('aeiu_2d', z2d) + CALL iom_put('aeiv_2d', z3d(:,:,1)) + ENDIF + + IF( iom_use("tosmint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) + END_3D + CALL iom_put( "tosmint", z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) + END_3D + CALL iom_put( "somint", z2d ) ! Vertical integral of salinity + ENDIF + + CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2) + + IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging + + ! Output of surface vorticity terms + ! + CALL iom_put( "ssplavor", ff_f ) ! planetary vorticity ( f ) + ! + IF ( iom_use("ssrelvor") .OR. iom_use("ssEns") .OR. & + & iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN + ! + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) & + & - e1u(ji ,jj+1) * uu(ji ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm) ) * r1_e1e2f(ji,jj) + END_2D + CALL iom_put( "ssrelvor", z2d ) ! relative vorticity ( zeta ) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN + DO_2D( 0, 0, 0, 0 ) + ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & + & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) + IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 + ELSE ; ze3 = 0._wp + ENDIF + z2d(ji,jj) = ze3 * z2d(ji,jj) + END_2D + CALL iom_put( "ssrelpotvor", z2d ) ! relative potential vorticity (zeta/h) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssabspotvor") ) THEN + DO_2D( 0, 0, 0, 0 ) + ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & + & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) + IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 + ELSE ; ze3 = 0._wp + ENDIF + z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj) + END_2D + CALL iom_put( "ssabspotvor", z2d ) ! absolute potential vorticity ( q ) + ! + IF ( iom_use("ssEns") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj) + END_2D + CALL iom_put( "ssEns", z2d ) ! potential enstrophy ( 1/2*q2 ) + ENDIF + ENDIF + ENDIF + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri + +#else + !!---------------------------------------------------------------------- + !! Default option use IOIPSL library + !!---------------------------------------------------------------------- + + INTEGER FUNCTION dia_wri_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + IF( nn_write == -1 ) THEN + dia_wri_alloc = 0 + ELSE + ierr = 0 + ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , & + & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , & + & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) ) + ! + dia_wri_alloc = MAXVAL(ierr) + CALL mpp_sum( 'diawri', dia_wri_alloc ) + ! + ENDIF + ! + END FUNCTION dia_wri_alloc + + INTEGER FUNCTION dia_wri_alloc_abl() + !!---------------------------------------------------------------------- + ALLOCATE( ndex_hA(jpi*jpj), ndex_A (jpi*jpj*jpkam1), STAT=dia_wri_alloc_abl) + CALL mpp_sum( 'diawri', dia_wri_alloc_abl ) + ! + END FUNCTION dia_wri_alloc_abl + + + SUBROUTINE dia_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri *** + !! + !! ** Purpose : Standard output of opa: dynamics and tracer fields + !! NETCDF format is used by default + !! + !! ** Method : At the beginning of the first time step (nit000), + !! define all the NETCDF files and fields + !! At each time step call histdef to compute the mean if ncessary + !! Each nn_write time step, output the instantaneous or mean fields + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + CHARACTER (len=40) :: clhstnam, clop, clmx ! local names + INTEGER :: inum = 11 ! temporary logical unit + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! error code return from allocation + INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers + INTEGER :: ipka ! ABL + INTEGER :: jn, ierror ! local integers + REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars + ! + REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ninist == 1 ) THEN !== Output the initial state and forcings ==! + CALL dia_wri_state( Kmm, 'output.init' ) + ninist = 0 + ENDIF + ! + IF( nn_write == -1 ) RETURN ! we will never do any output + ! + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! 0. Initialisation + ! ----------------- + + ll_print = .FALSE. ! local variable for debugging + ll_print = ll_print .AND. lwp + + ! Define frequency of output and means + clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) +#if defined key_diainstant + zsto = nn_write * rn_Dt + clop = "inst("//TRIM(clop)//")" +#else + zsto=rn_Dt + clop = "ave("//TRIM(clop)//")" +#endif + zout = nn_write * rn_Dt + zmax = ( nitend - nit000 + 1 ) * rn_Dt + + ! Define indices of the horizontal output zoom and vertical limit storage + iimi = Nis0 ; iima = Nie0 + ijmi = Njs0 ; ijma = Nje0 + ipk = jpk + IF(ln_abl) ipka = jpkam1 + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + ! 1. Define NETCDF files and fields at beginning of first time step + ! ----------------------------------------------------------------- + + IF( kt == nit000 ) THEN + + ! Define the NETCDF files (one per grid) + + ! Compute julian date from starting date of the run + CALL ymds2ju( nyear, nmonth, nday, rn_Dt, zjulian ) + zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear, & + & ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian + IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma, & + ' limit storage in depth = ', ipk + + ! WRITE root name in date.file for use by postpro + IF(lwp) THEN + CALL dia_nam( clhstnam, nn_write,' ' ) + CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + WRITE(inum,*) clhstnam + CLOSE(inum) + ENDIF + + ! Define the T grid FILE ( nid_T ) + + CALL dia_nam( clhstnam, nn_write, 'grid_T' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_T, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume + CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface + ! + IF( ln_icebergs ) THEN + ! + !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after + !! that routine is called from nemogcm, so do it here immediately before its needed + ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror ) + CALL mpp_sum( 'diawri', ierror ) + IF( ierror /= 0 ) THEN + CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array') + RETURN + ENDIF + ! + !! iceberg vertical coordinate is class number + CALL histvert( nid_T, "class", "Iceberg class", & ! Vertical grid: class + & "number", nclasses, class_num, nb_T ) + ! + !! each class just needs the surface index pattern + ndim_bT = 3 + DO jn = 1,nclasses + ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj) + ENDDO + ! + ENDIF + + ! Define the U grid FILE ( nid_U ) + + CALL dia_nam( clhstnam, nn_write, 'grid_U' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_U, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume + CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface + + ! Define the V grid FILE ( nid_V ) + + CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept + & "m", ipk, gdept_1d, nz_V, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume + CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface + + ! Define the W grid FILE ( nid_W ) + + CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw + & "m", ipk, gdepw_1d, nz_W, "down" ) + + IF( ln_abl ) THEN + ! Define the ABL grid FILE ( nid_A ) + CALL dia_nam( clhstnam, nn_write, 'grid_ABL' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_A, nid_A, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_A, "ght_abl", "Vertical T levels", & ! Vertical grid: gdept + & "m", ipka, ght_abl(2:jpka), nz_A, "up" ) + ! ! Index of ocean points + ALLOCATE( zw3d_abl(jpi,jpj,ipka) ) + zw3d_abl(:,:,:) = 1._wp + CALL wheneq( jpi*jpj*ipka, zw3d_abl, 1, 1., ndex_A , ndim_A ) ! volume + CALL wheneq( jpi*jpj , zw3d_abl, 1, 1., ndex_hA, ndim_hA ) ! surface + DEALLOCATE(zw3d_abl) + ENDIF + ! + + ! Declare all the output fields as NETCDF variables + + ! !!! nid_T : 3D + CALL histdef( nid_T, "votemper", "Temperature" , "C" , & ! tn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + IF( .NOT.ln_linssh ) THEN + CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_T : 2D + CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosaline", "Sea Surface Salinity" , "PSU" , & ! sss + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sossheig", "Sea Surface Height" , "m" , & ! ssh + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux" , "Kg/m2/s", & ! (emp-rnf) + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sorunoff", "River runoffs" , "Kg/m2/s", & ! runoffs + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + IF( ln_linssh ) THEN + CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * ts(:,:,1,jp_tem,Kmm) + & , "KgC/m2/s", & ! sosst_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * ts(:,:,1,jp_sal,Kmm) + & , "KgPSU/m2/s",& ! sosss_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "soshfldo", "Shortwave Radiation" , "W/m2" , & ! qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + IF( ALLOCATED(hmld) ) THEN ! zdf_mxl not called by SWE + CALL histdef( nid_T, "somixhgt", "Turbocline Depth" , "m" , & ! hmld + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01" , "m" , & ! hmlp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + CALL histdef( nid_T, "soicecov", "Ice fraction" , "[0,1]" , & ! fr_i + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowindsp", "wind speed at 10m" , "m/s" , & ! wndm + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ! + IF( ln_abl ) THEN + CALL histdef( nid_A, "t_abl", "Potential Temperature" , "K" , & ! t_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "q_abl", "Humidity" , "kg/kg" , & ! q_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "u_abl", "Atmospheric U-wind " , "m/s" , & ! u_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "v_abl", "Atmospheric V-wind " , "m/s" , & ! v_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "tke_abl", "Atmospheric TKE " , "m2/s2" , & ! tke_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "avm_abl", "Atmospheric turbulent viscosity", "m2/s" , & ! avm_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "avt_abl", "Atmospheric turbulent diffusivity", "m2/s2", & ! avt_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "pblh", "Atmospheric boundary layer height " , "m", & ! pblh + & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#if defined key_si3 + CALL histdef( nid_A, "oce_frac", "Fraction of open ocean" , " ", & ! ato_i + & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#endif + CALL histend( nid_A, snc4chunks=snc4set ) + ENDIF + ! + IF( ln_icebergs ) THEN + CALL histdef( nid_T, "calving" , "calving mass input" , "kg/s" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "calving_heat" , "calving heat flux" , "XXXX" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_floating_melt" , "Melt rate of icebergs + bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_stored_ice" , "Accumulated ice mass by class" , "kg" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + IF( ln_bergdia ) THEN + CALL histdef( nid_T, "berg_melt" , "Melt rate of icebergs" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_buoy_melt" , "Buoyancy component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_eros_melt" , "Erosion component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_conv_melt" , "Convective component of iceberg melt rate", "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_virtual_area" , "Virtual coverage by icebergs" , "m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_src" , "Mass source of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_melt" , "Melt rate of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_mass" , "Bergy bit density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_mass" , "Iceberg density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_real_calving" , "Calving into iceberg class" , "kg/s" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + + clmx ="l_max(only(x))" ! max index on a period +! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX +! & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clmx, zsto, zout ) +#if defined key_diahth + CALL histdef( nid_T, "sothedep", "Thermocline Depth" , "m" , & ! hth + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm" , "m" , & ! hd20 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm" , "m" , & ! hd28 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sohtc300", "Heat content 300 m" , "J/m2" , & ! htc3 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#endif + + CALL histend( nid_T, snc4chunks=snc4set ) + + ! !!! nid_U : 3D + CALL histdef( nid_U, "vozocrtx", "Zonal Current" , "m/s" , & ! uu(:,:,:,Kmm) + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_U, "sdzocrtx", "Stokes Drift Zonal Current" , "m/s" , & ! usd + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_U : 2D + CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau + & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_U, snc4chunks=snc4set ) + + ! !!! nid_V : 3D + CALL histdef( nid_V, "vomecrty", "Meridional Current" , "m/s" , & ! vv(:,:,:,Kmm) + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_V, "sdmecrty", "Stokes Drift Meridional Current" , "m/s" , & ! vsd + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_V : 2D + CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau + & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_V, snc4chunks=snc4set ) + + ! !!! nid_W : 3D + CALL histdef( nid_W, "vovecrtz", "Vertical Velocity" , "m/s" , & ! ww + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity" , "m2/s" , & ! avt + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity" , "m2/s" , & ! avm + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + + IF( ln_zdfddm ) THEN + CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity" , "m2/s" , & ! avs + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current" , "m/s" , & ! wsd + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_W : 2D + CALL histend( nid_W, snc4chunks=snc4set ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization' + IF(ll_print) CALL FLUSH(numout ) + + ENDIF + + ! 2. Start writing data + ! --------------------- + + ! ndex(1) est utilise ssi l'avant dernier argument est different de + ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument + ! donne le nombre d'elements, et ndex la liste des indices a sortir + + IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN + WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' + WRITE(numout,*) '~~~~~~ ' + ENDIF + + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) + END_3D + CALL histwrite( nid_T, "votemper", it, z3d, ndim_T , ndex_T ) ! heat content + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) + END_3D + CALL histwrite( nid_T, "vosaline", it, z3d, ndim_T , ndex_T ) ! salt content + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj ) = ts(ji,jj, 1,jp_tem,Kmm) * e3t(ji,jj, 1,Kmm) + END_2D + CALL histwrite( nid_T, "sosstsst", it, z2d, ndim_hT, ndex_hT ) ! sea surface heat content + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj ) = ts(ji,jj, 1,jp_sal,Kmm) * e3t(ji,jj, 1,Kmm) + END_2D + CALL histwrite( nid_T, "sosaline", it, z2d, ndim_hT, ndex_hT ) ! sea surface salinity content + ELSE + CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature + CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) , ndim_T , ndex_T ) ! salinity + CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) , ndim_hT, ndex_hT ) ! sea surface temperature + CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity + ENDIF + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL histwrite( nid_T, "vovvle3t", it, z3d , ndim_T , ndex_T ) ! level thickness + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL histwrite( nid_T, "vovvldep", it, z3d , ndim_T , ndex_T ) ! t-point depth + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ( ( e3t(ji,jj,jk,Kmm) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2 + END_3D + CALL histwrite( nid_T, "vovvldef", it, z3d , ndim_T , ndex_T ) ! level thickness deformation + ENDIF + CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm) , ndim_hT, ndex_hT ) ! sea surface height + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END_2D + CALL histwrite( nid_T, "sowaflup", it, z2d , ndim_hT, ndex_hT ) ! upward water flux + CALL histwrite( nid_T, "sorunoff", it, rnf , ndim_hT, ndex_hT ) ! river runoffs + CALL histwrite( nid_T, "sosfldow", it, sfx , ndim_hT, ndex_hT ) ! downward salt flux + ! (includes virtual salt flux beneath ice + ! in linear free surface case) + IF( ln_linssh ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_tem,Kmm) + END_2D + CALL histwrite( nid_T, "sosst_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sst + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_sal,Kmm) + END_2D + CALL histwrite( nid_T, "sosss_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sss + ENDIF + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) + END_2D + CALL histwrite( nid_T, "sohefldo", it, z2d , ndim_hT, ndex_hT ) ! total heat flux + CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux + IF( ALLOCATED(hmld) ) THEN ! zdf_mxl not called by SWE + CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth + CALL histwrite( nid_T, "somxl010", it, hmlp , ndim_hT, ndex_hT ) ! mixed layer depth + ENDIF + CALL histwrite( nid_T, "soicecov", it, fr_i , ndim_hT, ndex_hT ) ! ice fraction + CALL histwrite( nid_T, "sowindsp", it, wndm , ndim_hT, ndex_hT ) ! wind speed + ! + IF( ln_abl ) THEN + ALLOCATE( zw3d_abl(jpi,jpj,jpka) ) + IF( ln_mskland ) THEN + DO jk=1,jpka + zw3d_abl(:,:,jk) = tmask(:,:,1) + END DO + ELSE + zw3d_abl(:,:,:) = 1._wp + ENDIF + CALL histwrite( nid_A, "pblh" , it, pblh(:,:) *zw3d_abl(:,:,1 ), ndim_hA, ndex_hA ) ! pblh + CALL histwrite( nid_A, "u_abl" , it, u_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! u_abl + CALL histwrite( nid_A, "v_abl" , it, v_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! v_abl + CALL histwrite( nid_A, "t_abl" , it, tq_abl (:,:,2:jpka,nt_n,1)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! t_abl + CALL histwrite( nid_A, "q_abl" , it, tq_abl (:,:,2:jpka,nt_n,2)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! q_abl + CALL histwrite( nid_A, "tke_abl", it, tke_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! tke_abl + CALL histwrite( nid_A, "avm_abl", it, avm_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avm_abl + CALL histwrite( nid_A, "avt_abl", it, avt_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avt_abl +#if defined key_si3 + CALL histwrite( nid_A, "oce_frac" , it, ato_i(:,:) , ndim_hA, ndex_hA ) ! ato_i +#endif + DEALLOCATE(zw3d_abl) + ENDIF + ! + IF( ln_icebergs ) THEN + ! + CALL histwrite( nid_T, "calving" , it, berg_grid%calving , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "calving_heat" , it, berg_grid%calving_hflx , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_floating_melt" , it, berg_grid%floating_melt, ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_stored_ice" , it, berg_grid%stored_ice , ndim_bT, ndex_bT ) + ! + IF( ln_bergdia ) THEN + CALL histwrite( nid_T, "berg_melt" , it, berg_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_buoy_melt" , it, buoy_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_eros_melt" , it, eros_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_conv_melt" , it, conv_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_virtual_area" , it, virtual_area , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_src" , it, bits_src , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_melt" , it, bits_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_mass" , it, bits_mass , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_mass" , it, berg_mass , ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_real_calving" , it, real_calving , ndim_bT, ndex_bT ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping + CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = erp(ji,jj) * ts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + END_2D + CALL histwrite( nid_T, "sosafldp", it, z2d , ndim_hT, ndex_hT ) ! salt flux damping + ENDIF +! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) +! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ??? + +#if defined key_diahth + CALL histwrite( nid_T, "sothedep", it, hth , ndim_hT, ndex_hT ) ! depth of the thermocline + CALL histwrite( nid_T, "so20chgt", it, hd20 , ndim_hT, ndex_hT ) ! depth of the 20 isotherm + CALL histwrite( nid_T, "so28chgt", it, hd28 , ndim_hT, ndex_hT ) ! depth of the 28 isotherm + CALL histwrite( nid_T, "sohtc300", it, htc3 , ndim_hT, ndex_hT ) ! first 300m heaat content +#endif + + CALL histwrite( nid_U, "vozocrtx", it, uu(:,:,:,Kmm) , ndim_U , ndex_U ) ! i-current + CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress + + CALL histwrite( nid_V, "vomecrty", it, vv(:,:,:,Kmm) , ndim_V , ndex_V ) ! j-current + CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress + + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL histwrite( nid_W, "vovecrtz", it, z3d , ndim_T, ndex_T ) ! vert. current + ELSE + CALL histwrite( nid_W, "vovecrtz", it, ww , ndim_T, ndex_T ) ! vert. current + ENDIF + CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef. + CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef. + IF( ln_zdfddm ) THEN + CALL histwrite( nid_W, "voddmavs", it, avs , ndim_T, ndex_T ) ! S vert. eddy diff. coef. + ENDIF + + IF( ln_wave .AND. ln_sdw ) THEN + CALL histwrite( nid_U, "sdzocrtx", it, usd , ndim_U , ndex_U ) ! i-StokesDrift-current + CALL histwrite( nid_V, "sdmecrty", it, vsd , ndim_V , ndex_V ) ! j-StokesDrift-current + CALL histwrite( nid_W, "sdvecrtz", it, wsd , ndim_T , ndex_T ) ! StokesDrift vert. current + ENDIF + + ! 3. Close all files + ! --------------------------------------- + IF( kt == nitend ) THEN + CALL histclo( nid_T ) + CALL histclo( nid_U ) + CALL histclo( nid_V ) + CALL histclo( nid_W ) + IF(ln_abl) CALL histclo( nid_A ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri +#endif + + SUBROUTINE dia_wri_state( Kmm, cdfile_name ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri_state *** + !! + !! ** Purpose : create a NetCDF file named cdfile_name which contains + !! the instantaneous ocean state and forcing fields. + !! Used to find errors in the initial state or save the last + !! ocean state in case of abnormal end of a simulation + !! + !! ** Method : NetCDF files using ioipsl + !! File 'output.init.nc' is created if ninist = 1 (namelist) + !! File 'output.abort.nc' is created in case of abnormal job end + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kmm ! time level index + CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum + REAL(wp), DIMENSION(jpi,jpj) :: z2d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' + WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' + WRITE(numout,*) ' and named :', cdfile_name, '...nc' + ENDIF + ! + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) + ! + CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature + CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity + CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm) ) ! sea surface height + CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm) ) ! now i-velocity + CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL iom_rstput( 0, 0, inum, 'vovecrtz', z3d ) ! now k-velocity + ELSE + CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity + ENDIF + CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) + CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height + ! + IF ( ln_isf ) THEN + IF (ln_isfcav_mlt) THEN + CALL iom_rstput( 0, 0, inum, 'fwfisf_cav', fwfisf_cav ) + CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) + CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) + CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) + CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) + CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) + END IF + IF (ln_isfpar_mlt) THEN + CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) + CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) + CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) + CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) + END IF + END IF + ! + IF( ALLOCATED(ahtu) ) THEN + CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point + CALL iom_rstput( 0, 0, inum, 'ahtv', ahtv ) ! aht at v-point + ENDIF + IF( ALLOCATED(ahmt) ) THEN + CALL iom_rstput( 0, 0, inum, 'ahmt', ahmt ) ! ahmt at u-point + CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) ! ahmf at v-point + ENDIF + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END_2D + CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d ) ! freshwater budget + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) + END_2D + CALL iom_rstput( 0, 0, inum, 'sohefldo', z2d ) ! total heat flux + CALL iom_rstput( 0, 0, inum, 'soshfldo', qsr ) ! solar heat flux + CALL iom_rstput( 0, 0, inum, 'soicecov', fr_i ) ! ice fraction + CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress + CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d ) ! T-cell depth + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL iom_rstput( 0, 0, inum, 'vovvle3t', z3d ) ! T-cell thickness + END IF + IF( ln_wave .AND. ln_sdw ) THEN + CALL iom_rstput( 0, 0, inum, 'sdzocrtx', usd ) ! now StokesDrift i-velocity + CALL iom_rstput( 0, 0, inum, 'sdmecrty', vsd ) ! now StokesDrift j-velocity + CALL iom_rstput( 0, 0, inum, 'sdvecrtz', wsd ) ! now StokesDrift k-velocity + ENDIF + IF ( ln_abl ) THEN + CALL iom_rstput ( 0, 0, inum, "uz1_abl", u_abl(:,:,2,nt_a ) ) ! now first level i-wind + CALL iom_rstput ( 0, 0, inum, "vz1_abl", v_abl(:,:,2,nt_a ) ) ! now first level j-wind + CALL iom_rstput ( 0, 0, inum, "tz1_abl", tq_abl(:,:,2,nt_a,1) ) ! now first level temperature + CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity + ENDIF + IF( ln_zdfosm ) THEN + CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1) ) ! now boundary-layer depth + CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1) ) ! now mixed-layer depth + CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask ) ! w-level diffusion + CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask ) ! now w-level viscosity + CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask ) ! non-local t forcing + CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask ) ! non-local s forcing + CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask ) ! non-local u forcing + CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask ) ! non-local v forcing + IF( ln_osm_mle ) THEN + CALL iom_rstput( 0, 0, inum, 'hmle', hmle*tmask(:,:,1) ) ! now transition-layer depth + END IF + ENDIF + ! + CALL iom_close( inum ) + ! +#if defined key_si3 + IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid + CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) + CALL ice_wri_state( inum ) + CALL iom_close( inum ) + ENDIF + ! +#endif + END SUBROUTINE dia_wri_state + + !!====================================================================== +END MODULE diawri diff --git a/TMP_MY_SRC/domain.F90 b/TMP_MY_SRC/domain.F90 new file mode 100644 index 0000000..c4b1bfa --- /dev/null +++ b/TMP_MY_SRC/domain.F90 @@ -0,0 +1,805 @@ +MODULE domain + !!============================================================================== + !! *** MODULE domain *** + !! Ocean initialization : domain initialization + !!============================================================================== + !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code + !! ! 1992-01 (M. Imbard) insert time step initialization + !! ! 1996-06 (G. Madec) generalized vertical coordinate + !! ! 1997-02 (G. Madec) creation of domwri.F + !! ! 2001-05 (E.Durand - G. Madec) insert closed sea + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.3 ! 2010-11 (G. Madec) initialisation in C1D configuration + !! 3.6 ! 2013 ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs + !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default + !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface + !! 4.1 ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_init : initialize the space and time domain + !! dom_nam : read and contral domain namelists + !! dom_ctl : control print for the ocean domain + !! domain_cfg : read the global domain size in domain configuration file + !! cfg_write : create the domain configuration file + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! domain: ocean + USE domtile ! tiling utilities +#if defined key_qco + USE domqco ! quasi-eulerian coord. +#elif defined key_linssh + ! ! fix in time coord. +#else + USE domvvl ! variable volume coord. +#endif +#if defined key_agrif + USE agrif_oce_interp, ONLY : Agrif_istate_ssh ! ssh interpolated from parent +#if defined key_si3 + USE agrif_ice_interp, ONLY : agrif_istate_icevol ! ssh increment from ice +#endif +#endif + USE sbc_oce ! surface boundary condition: ocean + USE trc_oce ! shared ocean & passive tracers variab + USE phycst ! physical constants + USE domhgr ! domain: set the horizontal mesh + USE domzgr ! domain: set the vertical mesh + USE dommsk ! domain: set the mask system + USE domwri ! domain: write the meshmask file + USE wet_dry , ONLY : ll_wd ! wet & drying flag + USE closea , ONLY : dom_clo ! closed seas routine + USE c1d + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_mpp ! distributed memory computing library + USE restart ! only for lrst_oce and rst_read_ssh + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_init ! called by nemogcm.F90 + PUBLIC domain_cfg ! called by nemogcm.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domain.F90 14547 2021-02-25 17:07:15Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_init *** + !! + !! ** Purpose : Domain initialization. Call the routines that are + !! required to create the arrays which define the space + !! and time domain of the ocean model. + !! + !! ** Method : - dom_msk: compute the masks from the bathymetry file + !! - dom_hgr: compute or read the horizontal grid-point position + !! and scale factors, and the coriolis factor + !! - dom_zgr: define the vertical coordinate and the bathymetry + !! - dom_wri: create the meshmask file (ln_meshmask=T) + !! - 1D configuration, move Coriolis, u and v at T-point + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk, jt ! dummy loop indices + INTEGER :: iconf = 0 ! local integers + CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" + INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level + REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Ocean domain Parameters (control print) + WRITE(numout,*) + WRITE(numout,*) 'dom_init : domain initialization' + WRITE(numout,*) '~~~~~~~~' + ! + WRITE(numout,*) ' Domain info' + WRITE(numout,*) ' dimension of model:' + WRITE(numout,*) ' Local domain Global domain Data domain ' + WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo + WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo + WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpkglo : ', jpkglo + WRITE(numout,cform) ' ' ,' jpij : ', jpij + WRITE(numout,*) ' mpp local domain info (mpp):' + WRITE(numout,*) ' jpni : ', jpni, ' nn_hls : ', nn_hls + WRITE(numout,*) ' jpnj : ', jpnj, ' nn_hls : ', nn_hls + WRITE(numout,*) ' jpnij : ', jpnij + WRITE(numout,*) ' lateral boundary of the Global domain:' + WRITE(numout,*) ' cyclic east-west :', l_Iperio + WRITE(numout,*) ' cyclic north-south :', l_Jperio + WRITE(numout,*) ' North Pole folding :', l_NFold + WRITE(numout,*) ' type of North pole Folding:', c_NFtype + WRITE(numout,*) ' Ocean model configuration used:' + WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg + ENDIF + + ! + ! !== Reference coordinate system ==! + ! + CALL dom_nam ! read namelist ( namrun, namdom ) + CALL dom_tile_init ! Tile domain + + IF( ln_c1d ) CALL c1d_init ! 1D column configuration + ! + CALL dom_hgr ! Horizontal mesh + + IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes + + CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) + + CALL dom_msk( ik_top, ik_bot ) ! Masks + ! + ht_0(:,:) = 0._wp ! Reference ocean thickness + hu_0(:,:) = 0._wp + hv_0(:,:) = 0._wp + hf_0(:,:) = 0._wp + DO jk = 1, jpkm1 + ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) + hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) + hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) + END DO + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + hf_0(ji,jj) = hf_0(ji,jj) + e3f_0(ji,jj,jk)*vmask(ji,jj,jk)*vmask(ji+1,jj,jk) + END_3D + CALL lbc_lnk('domain', hf_0, 'F', 1._wp) + ! + IF( lk_SWE ) THEN ! SWE case redefine hf_0 + hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) + ENDIF + ! + r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) + r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) + r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) + ! + IF( ll_wd ) THEN ! wet and drying (check ht_0 >= 0) + DO_2D( 1, 1, 1, 1 ) + IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN + CALL ctl_stop( 'dom_init : ht_0 must be positive at potentially wet points' ) + ENDIF + END_2D + ENDIF + ! + ! !== initialisation of time varying coordinate ==! + ! + ! != ssh initialization + ! + IF( l_SAS ) THEN !* No ocean dynamics calculation : set to 0 + ssh(:,:,:) = 0._wp +#if defined key_agrif + ELSEIF( .NOT.Agrif_root() .AND. & + & ln_init_chfrpar ) THEN !* Interpolate initial ssh from parent + CALL Agrif_istate_ssh( Kbb, Kmm, Kaa ) +#if defined key_si3 + ! Possibly add ssh increment from parent grid + ! only if there is no ice model in the child grid + CALL Agrif_istate_icevol( Kbb, Kmm, Kaa ) +#endif +#endif + ELSE !* Read in restart file or set by user + CALL rst_read_ssh( Kbb, Kmm, Kaa ) + ENDIF + ! +#if defined key_qco + ! != Quasi-Euerian coordinate case + ! + IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) +#elif defined key_linssh + ! != Fix in time : key_linssh case, set through domzgr_substitute.h90 +#else + ! + IF( ln_linssh ) THEN != Fix in time : set to the reference one for all + ! + DO jt = 1, jpt ! depth of t- and w-grid-points + gdept(:,:,:,jt) = gdept_0(:,:,:) + gdepw(:,:,:,jt) = gdepw_0(:,:,:) + END DO + gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t + ! + DO jt = 1, jpt ! vertical scale factors + e3t (:,:,:,jt) = e3t_0(:,:,:) + e3u (:,:,:,jt) = e3u_0(:,:,:) + e3v (:,:,:,jt) = e3v_0(:,:,:) + e3w (:,:,:,jt) = e3w_0(:,:,:) + e3uw(:,:,:,jt) = e3uw_0(:,:,:) + e3vw(:,:,:,jt) = e3vw_0(:,:,:) + END DO + e3f (:,:,:) = e3f_0(:,:,:) + ! + DO jt = 1, jpt ! water column thickness and its inverse + hu(:,:,jt) = hu_0(:,:) + hv(:,:,jt) = hv_0(:,:) + r1_hu(:,:,jt) = r1_hu_0(:,:) + r1_hv(:,:,jt) = r1_hv_0(:,:) + END DO + ht (:,:) = ht_0(:,:) + ! + ELSE != Time varying : initialize before/now/after variables + ! + IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) + ! + ENDIF +#endif + + ! + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa ) +#endif + IF( ln_meshmask ) CALL dom_wri ! Create a domain file + IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control + ! + IF( ln_write_cfg ) CALL cfg_write ! create the configuration file + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_init : ==>>> END of domain initialization' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) + ENDIF + ! + END SUBROUTINE dom_init + + + SUBROUTINE dom_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** Purpose : read domaine namelists and print the variables. + !! + !! ** input : - namrun namelist + !! - namdom namelist + !! - namtile namelist + !! - namnc4 namelist ! "key_netcdf4" only + !!---------------------------------------------------------------------- + USE ioipsl + !! + INTEGER :: ios ! Local integer + REAL(wp):: zrdt + !!---------------------------------------------------------------------- + ! + NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & + & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , ln_reset_ts , & + & nn_rstctl , & + & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , & + & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, ln_1st_euler , & + & ln_cfmeta, ln_xios_read, nn_wxios + NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_c1d, ln_meshmask + NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j +#if defined key_netcdf4 + NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip +#endif + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_nam : domain initialization through namelist read' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + ! !=======================! + ! !== namelist namdom ==! + ! !=======================! + ! + READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) + READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) + IF(lwm) WRITE( numond, namdom ) + ! +#if defined key_linssh + ln_linssh = lk_linssh ! overwrite ln_linssh with the logical associated with key_linssh +#endif + ! +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep + rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() + ENDIF +#endif + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist : namdom --- space & time domain' + WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh + WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask + WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt + WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp + WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' single column domain (1x1pt) ln_c1d = ', ln_c1d + ENDIF + ! + ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 +#if defined key_RK3 + rDt = rn_Dt + r1_Dt = 1._wp / rDt + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> Runge Kutta 3rd order (RK3) : rDt = ', rDt + WRITE(numout,*) + ENDIF + ! +#else + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> Modified Leap-Frog (MLF) : rDt = ', rDt + WRITE(numout,*) + ENDIF + ! +#endif + ! + IF( l_SAS .AND. .NOT.ln_linssh ) THEN + CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) + ln_linssh = .TRUE. + ENDIF + ! +#if defined key_qco + IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) +#endif + ! + ! !=======================! + ! !== namelist namrun ==! + ! !=======================! + ! + READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) + READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' ) + IF(lwm) WRITE ( numond, namrun ) + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1 + nn_itend = Agrif_Parent(nn_itend) *Agrif_IRhot() + nn_date0 = Agrif_Parent(nn_date0) + nn_time0 = Agrif_Parent(nn_time0) + nn_leapy = Agrif_Parent(nn_leapy) + ENDIF +#endif + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namrun --- run parameters' + WRITE(numout,*) ' Assimilation cycle nn_no = ', nn_no + WRITE(numout,*) ' experiment name for output cn_exp = ', TRIM( cn_exp ) + WRITE(numout,*) ' file prefix restart input cn_ocerst_in = ', TRIM( cn_ocerst_in ) + WRITE(numout,*) ' restart input directory cn_ocerst_indir = ', TRIM( cn_ocerst_indir ) + WRITE(numout,*) ' file prefix restart output cn_ocerst_out = ', TRIM( cn_ocerst_out ) + WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', TRIM( cn_ocerst_outdir ) + WRITE(numout,*) ' restart logical ln_rstart = ', ln_rstart + WRITE(numout,*) ' reset TS from inital TS file ln_reset_ts = ', ln_reset_ts + WRITE(numout,*) ' start with forward time step ln_1st_euler = ', ln_1st_euler + WRITE(numout,*) ' control of time step nn_rstctl = ', nn_rstctl + WRITE(numout,*) ' number of the first time step nn_it000 = ', nn_it000 + WRITE(numout,*) ' number of the last time step nn_itend = ', nn_itend + WRITE(numout,*) ' initial calendar date aammjj nn_date0 = ', nn_date0 + WRITE(numout,*) ' initial time of day in hhmm nn_time0 = ', nn_time0 + WRITE(numout,*) ' leap year calendar (0/1) nn_leapy = ', nn_leapy + WRITE(numout,*) ' initial state output nn_istate = ', nn_istate + IF( ln_rst_list ) THEN + WRITE(numout,*) ' list of restart dump times nn_stocklist =', nn_stocklist + ELSE + WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock + ENDIF +#if ! defined key_xios + WRITE(numout,*) ' frequency of output file nn_write = ', nn_write +#endif + WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland + WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta + WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber + WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + WRITE(numout,*) ' READ restart for a single file using XIOS ln_xios_read =', ln_xios_read + WRITE(numout,*) ' Write restart using XIOS nn_wxios = ', nn_wxios + ELSE + WRITE(numout,*) " AGRIF: nn_wxios will be ingored. See setting for parent" + WRITE(numout,*) " AGRIF: ln_xios_read will be ingored. See setting for parent" + ENDIF + ENDIF + + cexper = cn_exp ! conversion DOCTOR names into model names (this should disappear soon) + nrstdt = nn_rstctl + nit000 = nn_it000 + nitend = nn_itend + ndate0 = nn_date0 + nleapy = nn_leapy + ninist = nn_istate + ! + ! !== Set parameters for restart reading using xIOS ==! + ! + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + lrxios = ln_xios_read .AND. ln_rstart + IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist + nxioso = nn_wxios + ENDIF + ! +#if defined key_RK3 + ! !== RK3: Open the restart file ==! + IF( ln_rstart ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' open the restart file' + CALL rst_read_open + ENDIF +#else + ! !== MLF: Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) + l_1st_euler = ln_1st_euler + ! + IF( ln_rstart ) THEN !* Restart case + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' open the restart file' + CALL rst_read_open !- Open the restart file + ! + IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN !- Check time-step consistency and force Euler restart if changed + CALL iom_get( numror, 'rdt', zrdt ) + IF( zrdt /= rn_Dt ) THEN + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' + l_1st_euler = .TRUE. + ENDIF + ENDIF + ! + IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN !- Check absence of one of the Kbb field (here sshb) + ! ! (any Kbb field is missing ==> all Kbb fields are missing) + IF( .NOT.l_1st_euler ) THEN + CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ', & + & 'l_1st_euler forced to .true. and ' , & + & 'ssh(Kbb) = ssh(Kmm) ' ) + l_1st_euler = .TRUE. + ENDIF + ENDIF + ELSEIF( .NOT.l_1st_euler ) THEN !* Initialization case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' + IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' + l_1st_euler = .TRUE. + ENDIF +#endif + ! + ! !== control of output frequency ==! + ! + IF( .NOT. ln_rst_list ) THEN ! we use nn_stock + IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) + IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN + WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_stock = nitend + ENDIF + ENDIF +#if ! defined key_xios + IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) + IF ( nn_write == 0 ) THEN + WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_write = nitend + ENDIF +#endif + + IF( Agrif_Root() ) THEN + IF(lwp) WRITE(numout,*) + SELECT CASE ( nleapy ) !== Choose calendar for IOIPSL ==! + CASE ( 1 ) + CALL ioconf_calendar('gregorian') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' + CASE ( 0 ) + CALL ioconf_calendar('noleap') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' + CASE ( 30 ) + CALL ioconf_calendar('360d') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' + END SELECT + ENDIF + ! + ! !========================! + ! !== namelist namtile ==! + ! !========================! + ! + READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) + READ ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtile in configuration namelist' ) + IF(lwm) WRITE( numond, namtile ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition' + WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile + WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i + WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j + WRITE(numout,*) + IF( ln_tile ) THEN + WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j + ELSE + WRITE(numout,*) ' Domain tiling will NOT be used' + ENDIF + ENDIF + ! +#if defined key_netcdf4 + ! !=======================! + ! !== namelist namnc4 ==! NetCDF 4 case ("key_netcdf4" defined) + ! !=======================! + ! + READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) + READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) + IF(lwm) WRITE( numond, namnc4 ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' + WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i + WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j + WRITE(numout,*) ' number of chunks in k-dimension nn_nchunks_k = ', nn_nchunks_k + WRITE(numout,*) ' apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip + ENDIF + + ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module) + ! Note the chunk size in the unlimited (time) dimension will be fixed at 1 + snc4set%ni = nn_nchunks_i + snc4set%nj = nn_nchunks_j + snc4set%nk = nn_nchunks_k + snc4set%luse = ln_nc4zip +#else + snc4set%luse = .FALSE. ! No NetCDF 4 case +#endif + ! + END SUBROUTINE dom_nam + + + SUBROUTINE dom_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ctl *** + !! + !! ** Purpose : Domain control. + !! + !! ** Method : compute and print extrema of masked scale factors + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(jpi,jpj) :: llmsk + INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2 + REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max + !!---------------------------------------------------------------------- + ! + llmsk = tmask_i(:,:) == 1._wp + ! + CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) + CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) + CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) + CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) + CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) + CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) + CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2) + WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2) + WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2) + WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2) + WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) + WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) + WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) + WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) + ENDIF + ! + END SUBROUTINE dom_ctl + + + SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE domain_cfg *** + !! + !! ** Purpose : read the domain size in domain configuration file + !! + !! ** Method : read the cn_domcfg NetCDF file + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name + INTEGER , INTENT(out) :: kk_cfg ! configuration resolution + INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes + LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity + LOGICAL , INTENT(out) :: ldNFold ! North pole folding + CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F + ! + CHARACTER(len=7) :: catt ! 'T', 'F', '-' or 'UNKNOWN' + INTEGER :: inum, iperio, iatt ! local integer + REAL(wp) :: zorca_res ! local scalars + REAL(wp) :: zperio ! - - + INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' + WRITE(numout,*) '~~~~~~~~~~ ' + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + CALL iom_getatt( inum, 'CfgName', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'CfgIndex', kk_cfg ) ! returns -999 if not found + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( cd_cfg == 'UNKNOWN' .AND. kk_cfg == -999 ) THEN + IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN + ! + cd_cfg = 'ORCA' + CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) + ! + ELSE + CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found + ENDIF + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo + kpi = idimsz(1) + kpj = idimsz(2) + kpk = idimsz(3) + ! + CALL iom_getatt( inum, 'Iperio', iatt ) ; ldIperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'Jperio', iatt ) ; ldJperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFold', iatt ) ; ldNFold = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFtype', catt ) ! returns 'UNKNOWN' if not found + IF( LEN_TRIM(catt) == 1 ) THEN ; cdNFtype = TRIM(catt) + ELSE ; cdNFtype = '-' + ENDIF + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( iatt == -999 .AND. catt == 'UNKNOWN' .AND. iom_varid( inum, 'jperio', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( inum, 'jperio', zperio ) ; iperio = NINT( zperio ) + ldIperio = iperio == 1 .OR. iperio == 4 .OR. iperio == 6 .OR. iperio == 7 ! i-periodicity + ldJperio = iperio == 2 .OR. iperio == 7 ! j-periodicity + ldNFold = iperio >= 3 .AND. iperio <= 6 ! North pole folding + IF( iperio == 3 .OR. iperio == 4 ) THEN ; cdNFtype = 'T' ! folding at T point + ELSEIF( iperio == 5 .OR. iperio == 6 ) THEN ; cdNFtype = 'F' ! folding at F point + ELSE ; cdNFtype = '-' ! default value + ENDIF + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + CALL iom_close( inum ) + ! + IF(lwp) THEN + WRITE(numout,*) ' .' + WRITE(numout,*) ' ==>>> ', TRIM(cn_cfg), ' configuration ' + WRITE(numout,*) ' .' + WRITE(numout,*) ' nn_cfg = ', kk_cfg + WRITE(numout,*) ' Ni0glo = ', kpi + WRITE(numout,*) ' Nj0glo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + ENDIF + ! + END SUBROUTINE domain_cfg + + + SUBROUTINE cfg_write + !!---------------------------------------------------------------------- + !! *** ROUTINE cfg_write *** + !! + !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which + !! contains all the ocean domain informations required to + !! define an ocean configuration. + !! + !! ** Method : Write in a file all the arrays required to set up an + !! ocean configuration. + !! + !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal + !! mesh, Coriolis parameter, and vertical scale factors + !! NB: also contain ORCA family information + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local units + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out),'.nc)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~' + ! + ! ! ============================= ! + ! ! create 'domcfg_out.nc' file ! + ! ! ============================= ! + ! + clnam = cn_domcfg_out ! filename (configuration information) + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) + ! + ! !== Configuration specificities ==! + ! + CALL iom_putatt( inum, 'CfgName', TRIM(cn_cfg) ) + CALL iom_putatt( inum, 'CfgIndex', nn_cfg ) + ! + ! !== domain characteristics ==! + ! + ! ! lateral boundary of the global domain + CALL iom_putatt( inum, 'Iperio', COUNT( (/l_Iperio/) ) ) + CALL iom_putatt( inum, 'Jperio', COUNT( (/l_Jperio/) ) ) + CALL iom_putatt( inum, 'NFold', COUNT( (/l_NFold /) ) ) + CALL iom_putatt( inum, 'NFtype', c_NFtype ) + + ! ! type of vertical coordinate + IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' ) + IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' ) + IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' ) + + ! ! ocean cavities under iceshelves + CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) ) + ! + ! !== horizontal mesh ! + ! + CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! latitude + CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude + CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.) + CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1v' , e1v , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1f' , e1f , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e2t' , e2t , ktype = jp_r8 ) ! j-scale factors (e2.) + CALL iom_rstput( 0, 0, inum, 'e2u' , e2u , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2v' , e2v , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2f' , e2f , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'ff_f' , ff_f , ktype = jp_r8 ) ! coriolis factor + CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 ) + ! + ! !== vertical mesh ==! + ! + CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate + CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) ! vertical scale factors + CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 ) + ! + ! !== wet top and bottom level ==! (caution: multiplied by ssmask) + ! + CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) + CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points + ! + IF( ln_sco ) THEN ! s-coordinate: store grid stiffness ratio (Not required anyway) + CALL dom_stiff( z2d ) + CALL iom_rstput( 0, 0, inum, 'stiffness', z2d ) ! ! Max. grid stiffness ratio + ENDIF + ! + IF( ll_wd ) THEN ! wetting and drying domain + CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) + ENDIF + ! ! ============================ ! + ! ! close the files + ! ! ============================ ! + CALL iom_close( inum ) + ! + END SUBROUTINE cfg_write + + !!====================================================================== +END MODULE domain diff --git a/TMP_MY_SRC/domzgr.F90 b/TMP_MY_SRC/domzgr.F90 new file mode 100644 index 0000000..defae11 --- /dev/null +++ b/TMP_MY_SRC/domzgr.F90 @@ -0,0 +1,323 @@ +MODULE domzgr + !!============================================================================== + !! *** MODULE domzgr *** + !! Ocean domain : definition of the vertical coordinate system + !!============================================================================== + !! History : OPA ! 1995-12 (G. Madec) Original code : s vertical coordinate + !! ! 1997-07 (G. Madec) lbc_lnk call + !! ! 1997-04 (J.-O. Beismann) + !! 8.5 ! 2002-09 (A. Bozec, G. Madec) F90: Free form and module + !! - ! 2002-09 (A. de Miranda) rigid-lid + islands + !! NEMO 1.0 ! 2003-08 (G. Madec) F90: Free form and module + !! - ! 2005-10 (A. Beckmann) modifications for hybrid s-ccordinates & new stretching function + !! 2.0 ! 2006-04 (R. Benshila, G. Madec) add zgr_zco + !! 3.0 ! 2008-06 (G. Madec) insertion of domzgr_zps.h90 & conding style + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case + !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye + !! 3.? ! 2015-11 (H. Liu) Modifications for Wetting/Drying + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_zgr : read or set the ocean vertical coordinate system + !! zgr_read : read the vertical information in the domain configuration file + !! zgr_top_bot : ocean top and bottom level for t-, u, and v-points with 1 as minimum value + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE usrdef_zgr ! user defined vertical coordinate system + USE closea ! closed seas + USE depth_e3 ! depth <=> e3 + USE wet_dry, ONLY: ll_wd, ssh_ref ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_zgr ! called by dom_init.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domzgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_zgr( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_zgr *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) + !! - read/set ocean depth and ocean levels (bathy, mbathy) + !! - vertical coordinate (gdep., e3.) depending on the + !! coordinate chosen : + !! ln_zco=T z-coordinate + !! ln_zps=T z-coordinate with partial steps + !! ln_zco=T s-coordinate + !! + !! ** Action : define gdep., e3., mbathy and bathy + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices + ! + INTEGER :: jk ! dummy loop index + INTEGER :: ioptio, ibat, ios ! local integer + REAL(wp) :: zrefdep ! depth of the reference level (~10m) + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dom_zgr : vertical coordinate' + WRITE(numout,*) '~~~~~~~' + ENDIF + + IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' + + + IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Read vertical mesh in ', TRIM( cn_domcfg ), ' file' + ! + CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot ) ! 1st & last ocean level + ! +! DRM 07/08/17 - Modify the top_level (ztop) and bottom_level (zbot) arrays to mask fake ocean points in +! Antarctica. Need to convert the indices to the local values. + k_top( mi0(5), mj0(5):mj0(405) ) = 0 + k_bot( mi0(5), mj0(5):mj0(405) ) = 0 + ELSE !== User defined configuration ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' + ! + CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot ) ! 1st & last ocean level + ! + ENDIF + ! +!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears + ! Compute gde3w_0 (vertical sum of e3w) + gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) + DO jk = 2, jpk + gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) + END DO + ! + ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled + ! in at runtime if ln_closea=.false. + IF( .NOT.ln_closea ) CALL clo_bat( k_top, k_bot ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :' + WRITE(numout,*) ' z-coordinate - full steps ln_zco = ', ln_zco + WRITE(numout,*) ' z-coordinate - partial steps ln_zps = ', ln_zps + WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco + WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav + ENDIF + + ioptio = 0 ! Check Vertical coordinate options + IF( ln_zco ) ioptio = ioptio + 1 + IF( ln_zps ) ioptio = ioptio + 1 + IF( ln_sco ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( ' none or several vertical coordinate options used' ) + + + ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) + CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 + + + ! ! deepest/shallowest W level Above/Below ~10m +!!gm BUG in s-coordinate this does not work! + zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) + nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m + nla10 = nlb10 - 1 ! deepest W level Above ~10m +!!gm end bug + ! + IF( nprint == 1 .AND. lwp ) THEN + WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) + WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) + WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & + & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), & + & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), & + & ' uw', MINVAL( e3uw_0(:,:,:) ), ' vw', MINVAL( e3vw_0(:,:,:)), & + & ' w ', MINVAL( e3w_0(:,:,:) ) + + WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & + & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), & + & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), & + & ' uw', MAXVAL( e3uw_0(:,:,:) ), ' vw', MAXVAL( e3vw_0(:,:,:) ), & + & ' w ', MAXVAL( e3w_0(:,:,:) ) + ENDIF + ! + END SUBROUTINE dom_zgr + + + SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE zgr_read *** + !! + !! ** Purpose : Read the vertical information in the domain configuration file + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + ! + INTEGER :: jk ! dummy loop index + INTEGER :: inum ! local logical unit + REAL(WP) :: z_zco, z_zps, z_sco, z_cav + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file' + WRITE(numout,*) ' ~~~~~~~~' + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + ! !* type of vertical coordinate + CALL iom_get( inum, 'ln_zco' , z_zco ) + CALL iom_get( inum, 'ln_zps' , z_zps ) + CALL iom_get( inum, 'ln_sco' , z_sco ) + IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF + IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF + IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF + ! + ! !* ocean cavities under iceshelves + CALL iom_get( inum, 'ln_isfcav', z_cav ) + IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF + ! + ! !* vertical scale factors + CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate + CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) + ! + CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate + CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) + ! + ! !* depths + ! !- old depth definition (obsolescent feature) + IF( iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN + CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & + & ' depths at t- and w-points read in the domain configuration file') + CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) + CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) + CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) + ! + ELSE !- depths computed from e3. scale factors + CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth + CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' + WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) + WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) + ENDIF + ENDIF + ! + ! !* ocean top and bottom level + CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) + k_top(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points + k_bot(:,:) = NINT( z2d(:,:) ) + ! + ! reference depth for negative bathy (wetting and drying only) + IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) + ! + CALL iom_close( inum ) + ! + END SUBROUTINE zgr_read + + + SUBROUTINE zgr_top_bot( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_top_bot *** + !! + !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) + !! + !! ** Method : computes from k_top and k_bot with a minimum value of 1 over land + !! + !! ** Action : mikt, miku, mikv : vertical indices of the shallowest + !! ocean level at t-, u- & v-points + !! (min value = 1) + !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest + !! ocean level at t-, u- & v-points + !! (min value = 1 over land) + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + ! + mikt(:,:) = MAX( k_top(:,:) , 1 ) ! top ocean k-index of T-level (=1 over land) + ! + mbkt(:,:) = MAX( k_bot(:,:) , 1 ) ! bottom ocean k-index of T-level (=1 over land) + + ! ! N.B. top k-index of W-level = mikt + ! ! bottom k-index of W-level = mbkt+1 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) + mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) + mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) + ! + mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) + END DO + END DO + ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + END SUBROUTINE zgr_top_bot + + !!====================================================================== +END MODULE domzgr diff --git a/TMP_MY_SRC/dtatsd.F90 b/TMP_MY_SRC/dtatsd.F90 new file mode 100644 index 0000000..31d623d --- /dev/null +++ b/TMP_MY_SRC/dtatsd.F90 @@ -0,0 +1,281 @@ +MODULE dtatsd + !!====================================================================== + !! *** MODULE dtatsd *** + !! Ocean data : read ocean Temperature & Salinity Data from gridded data + !!====================================================================== + !! History : OPA ! 1991-03 () Original code + !! - ! 1992-07 (M. Imbard) + !! 8.0 ! 1999-10 (M.A. Foujols, M. Imbard) NetCDF FORMAT + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Bricaud, S. Masson) use of fldread + !! 3.4 ! 2010-11 (G. Madec, C. Ethe) Merge of dtatem and dtasal + remove CPP keys + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_tsd : read and time interpolated ocean Temperature & Salinity Data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE domtile + USE fldread ! read input fields + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_tsd_init ! called by opa.F90 + PUBLIC dta_tsd ! called by istate.F90 and tradmp.90 + + ! !!* namtsd namelist : Temperature & Salinity Data * + LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag + LOGICAL , PUBLIC :: ln_tsd_dmp !: internal damping toward input data flag + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsd ! structure of input SST (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dtatsd.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_tsd_init( ld_tradmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_tsd_init *** + !! + !! ** Purpose : initialisation of T & S input data + !! + !! ** Method : - Read namtsd namelist + !! - allocates T & S data structure + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ld_tradmp ! force the initialization when tradp is used + ! + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N), DIMENSION( jpts) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_tem, sn_sal + !! + NAMELIST/namtsd/ ln_tsd_init, ln_tsd_dmp, cn_dir, sn_tem, sn_sal + !!---------------------------------------------------------------------- + ! + ! Initialisation + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + ! + READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) + READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) + IF(lwm) WRITE ( numond, namtsd ) + + IF( PRESENT( ld_tradmp ) ) ln_tsd_dmp = .TRUE. ! forces the initialization when tradmp is used + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dta_tsd_init : Temperature & Salinity data ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namtsd' + WRITE(numout,*) ' Initialisation of ocean T & S with T &S input data ln_tsd_init = ', ln_tsd_init + WRITE(numout,*) ' damping of ocean T & S toward T &S input data ln_tsd_dmp = ', ln_tsd_dmp + WRITE(numout,*) + IF( .NOT.ln_tsd_init .AND. .NOT.ln_tsd_dmp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>> T & S data not used' + ENDIF + ENDIF + ! + IF( ln_rstart .AND. ln_tsd_init ) THEN + CALL ctl_warn( 'dta_tsd_init: ocean restart and T & S data intialisation, ', & + & 'we keep the restart T & S values and set ln_tsd_init to FALSE' ) + ln_tsd_init = .FALSE. + ENDIF + ! + ! ! allocate the arrays (if necessary) + IF( ln_tsd_init .OR. ln_tsd_dmp .OR. ln_reset_ts) THEN + ! + ALLOCATE( sf_tsd(jpts), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsd structure' ) ; RETURN + ENDIF + ! + ALLOCATE( sf_tsd(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( sn_tem%ln_tint ) ALLOCATE( sf_tsd(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + ALLOCATE( sf_tsd(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_sal%ln_tint ) ALLOCATE( sf_tsd(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + ! + IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'dta_tsd : unable to allocate T & S data arrays' ) ; RETURN + ENDIF + ! ! fill sf_tsd with sn_tem & sn_sal and control print + slf_i(jp_tem) = sn_tem ; slf_i(jp_sal) = sn_sal + CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity data', 'namtsd', no_print ) + ! + ENDIF + ! + END SUBROUTINE dta_tsd_init + + + SUBROUTINE dta_tsd( kt, ptsd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_tsd *** + !! + !! ** Purpose : provides T and S data at kt + !! + !! ** Method : - call fldread routine + !! - ORCA_R2: add some hand made alteration to read data + !! - s- or mixed z-s coordinate: vertical interpolation on model mesh + !! - ln_tsd_dmp=F: deallocates the T-S data structure + !! as T-S data are no are used + !! + !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data + ! + INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies + INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers + INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n + REAL(wp):: zl, zi ! local scalars + REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain + IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain + CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! + ! + ! +!!gm This should be removed from the code ===>>>> T & S files has to be changed + ! + ! !== ORCA_R2 configuration and T & S damping ==! + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations + irec_n(jp_tem) = sf_tsd(jp_tem)%nrec(2,sf_tsd(jp_tem)%naa) ! Determine if there is new data (ln_tint = F) + irec_n(jp_sal) = sf_tsd(jp_sal)%nrec(2,sf_tsd(jp_sal)%naa) ! If not, then do not apply the increments + IF( kt == nit000 ) irec_b(:) = -1 + ! + ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea + ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 + IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp + sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp + sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp + END DO + END DO + irec_b(jp_tem) = irec_n(jp_tem) + ENDIF + ! + IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp + sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp + sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp + sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp + END DO + END DO + irec_b(jp_sal) = irec_n(jp_sal) + ENDIF + ! + ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea + ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp + ENDIF + ENDIF +!!gm end + IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain + ENDIF + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) + END_3D + ! + IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( ( kt == nit000 .OR. ln_reset_ts ) .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' + ENDIF + ENDIF + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S + DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points + zl = gdept_0(ji,jj,jk) + IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data + ztp(jk) = ptsd(ji,jj,1 ,jp_tem) + zsp(jk) = ptsd(ji,jj,1 ,jp_sal) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data + ztp(jk) = ptsd(ji,jj,jpkm1,jp_tem) + zsp(jk) = ptsd(ji,jj,jpkm1,jp_sal) + ELSE ! inbetween : vertical interpolation between jkk & jkk+1 + DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) + IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN + zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) + ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi + zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 + ptsd(ji,jj,jk,jp_tem) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord + ptsd(ji,jj,jk,jp_sal) = zsp(jk) * tmask(ji,jj,jk) + END DO + ptsd(ji,jj,jpk,jp_tem) = 0._wp + ptsd(ji,jj,jpk,jp_sal) = 0._wp + END_2D + ! + ELSE !== z- or zps- coordinate ==! + ! + ! We must keep this definition in a case different from the general case of s-coordinate as we don't + ! want to use "underground" values (levels below ocean bottom) to be able to start the model from + ! masked temp and sal (read for example in a restart or in output.init) + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! Mask + ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) + END_3D + ! + IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) + ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) + ENDIF + ik = mikt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) + ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem) + ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal) + END IF + END_2D + ENDIF + ! + ENDIF + ! + IF( .NOT.ln_tsd_dmp ) THEN !== deallocate T & S structure ==! + ! (data used only for initialisation) + IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run' + DEALLOCATE( sf_tsd(jp_tem)%fnow ) ! T arrays in the structure + IF( sf_tsd(jp_tem)%ln_tint ) DEALLOCATE( sf_tsd(jp_tem)%fdta ) + DEALLOCATE( sf_tsd(jp_sal)%fnow ) ! S arrays in the structure + IF( sf_tsd(jp_sal)%ln_tint ) DEALLOCATE( sf_tsd(jp_sal)%fdta ) + DEALLOCATE( sf_tsd ) ! the structure itself + ENDIF + ! + END SUBROUTINE dta_tsd + + !!====================================================================== +END MODULE dtatsd diff --git a/TMP_MY_SRC/in_out_manager.F90 b/TMP_MY_SRC/in_out_manager.F90 new file mode 100644 index 0000000..38dcce1 --- /dev/null +++ b/TMP_MY_SRC/in_out_manager.F90 @@ -0,0 +1,195 @@ +MODULE in_out_manager + !!====================================================================== + !! *** MODULE in_out_manager *** + !! I/O manager utilities : Defines run parameters together with logical units + !!===================================================================== + !! History : 1.0 ! 2002-06 (G. Madec) original code + !! 2.0 ! 2006-07 (S. Masson) iom, add ctl_stop, ctl_warn + !! 3.0 ! 2008-06 (G. Madec) add ctmp4 to ctmp10 + !! 3.2 ! 2009-08 (S. MAsson) add new ctl_opn + !! 3.3 ! 2010-10 (A. Coward) add NetCDF4 usage + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameter + USE nc4interface ! NetCDF4 interface + + IMPLICIT NONE + PUBLIC + + !!---------------------------------------------------------------------- + !! namrun namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(lc) :: cn_exp !: experiment name used for output filename + CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input) + CHARACTER(lc) :: cn_ocerst_indir !: restart input directory + CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output) + CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory + LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file + LOGICAL :: ln_reset_ts !: use TS from initial condition file? (F) no or (T) yes + LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) + INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) + INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) + INTEGER :: nn_it000 !: index of the first time step + INTEGER :: nn_itend !: index of the last time step + INTEGER :: nn_date0 !: initial calendar date aammjj + INTEGER :: nn_time0 !: initial time of day in hhmm + INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: nn_istate !: initial state output flag (0/1) + INTEGER :: nn_write !: model standard output frequency + INTEGER :: nn_stock !: restart file frequency + INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times + LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) + LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard + LOGICAL :: ln_clobber !: clobber (overwrite) an existing file + INTEGER :: nn_chunksz !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + LOGICAL :: ln_xios_read !: use xios to read single file restart + INTEGER :: nn_wxios !: write resart using xios 0 - no, 1 - single, 2 - multiple file output + INTEGER :: nn_no !: Assimilation cycle + +#if defined key_netcdf4 + !!---------------------------------------------------------------------- + !! namnc4 namelist parameters (key_netcdf4) + !!---------------------------------------------------------------------- + ! The following four values determine the partitioning of the output fields + ! into netcdf4 chunks. They are unrelated to the nn_chunk_sz setting which is + ! for runtime optimisation. The individual netcdf4 chunks can be optionally + ! gzipped (recommended) leading to significant reductions in I/O volumes + ! !!!** variables only used with iom_nf90 routines and key_netcdf4 ** + INTEGER :: nn_nchunks_i !: number of chunks required in the i-dimension + INTEGER :: nn_nchunks_j !: number of chunks required in the j-dimension + INTEGER :: nn_nchunks_k !: number of chunks required in the k-dimension + INTEGER :: nn_nchunks_t !: number of chunks required in the t-dimension + LOGICAL :: ln_nc4zip !: netcdf4 usage: (T) chunk and compress output using the HDF5 sublayers of netcdf4 + ! ! (F) ignore chunking request and use the netcdf4 library + ! ! to produce netcdf3-compatible files +#endif + +!$AGRIF_DO_NOT_TREAT + TYPE(snc4_ctl) :: snc4set !: netcdf4 chunking control structure (always needed for decision making) +!$AGRIF_END_DO_NOT_TREAT + + + !! conversion of DOCTOR norm namelist name into model name + !! (this should disappear in a near futur) + + CHARACTER(lc) :: cexper !: experiment name used for output filename + INTEGER :: nrstdt !: control of the time step (0, 1 or 2) + INTEGER :: nit000 !: index of the first time step + INTEGER :: nitend !: index of the last time step + INTEGER :: ndate0 !: initial calendar date aammjj + INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: ninist !: initial state output flag (0/1) + + !!---------------------------------------------------------------------- + !! was in restart but moved here because of the OFF line... better solution should be found... + !!---------------------------------------------------------------------- + INTEGER :: nitrst !: time step at which restart file should be written + LOGICAL :: lrst_oce !: logical to control the oce restart write + LOGICAL :: lrst_ice !: logical to control the ice restart write + LOGICAL :: lrst_abl !: logical to control the abl restart write + INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) + INTEGER :: numrir = 0 !: logical unit for ice restart (read) + INTEGER :: numrar = 0 !: logical unit for abl restart (read) + INTEGER :: numrow = 0 !: logical unit for ocean restart (write) + INTEGER :: numriw = 0 !: logical unit for ice restart (write) + INTEGER :: numraw = 0 !: logical unit for abl restart (write) + INTEGER :: numrtr = 0 !: trc restart (read ) + INTEGER :: numrtw = 0 !: trc restart (write ) + INTEGER :: numrsr = 0 !: logical unit for sed restart (read) + INTEGER :: numrsw = 0 !: logical unit for sed restart (write) + + INTEGER :: nrst_lst !: number of restart to output next + + !!---------------------------------------------------------------------- + !! output monitoring + !!---------------------------------------------------------------------- + TYPE :: sn_ctl !: structure for control over output selection + LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F) + LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F) + LOGICAL :: l_oceout = .FALSE. !: Produce all ocean.outputs (T) or just one (F) + LOGICAL :: l_layout = .FALSE. !: Produce all layout.dat files (T) or just one (F) + LOGICAL :: l_prtctl = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) + LOGICAL :: l_prttrc = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F) + LOGICAL :: l_oasout = .FALSE. !: Produce/do not write oasis setup info to ocean.output (T/F) + ! Optional subsetting of processor report files + ! Default settings of 0/1000000/1 should ensure all areas report. + ! Set to a more restrictive range to select specific areas + INTEGER :: procmin = 0 !: Minimum narea to output + INTEGER :: procmax = 1000000 !: Maximum narea to output + INTEGER :: procincr = 1 !: narea increment to output + INTEGER :: ptimincr = 1 !: timestep increment to output (time.step and run.stat) + END TYPE + TYPE(sn_ctl), SAVE :: sn_cfctl !: run control structure for selective output, must have SAVE for default init. of sn_ctl + LOGICAL :: ln_timing !: run control for timing + LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics + INTEGER :: nn_ictls !: Start i indice for the SUM control + INTEGER :: nn_ictle !: End i indice for the SUM control + INTEGER :: nn_jctls !: Start j indice for the SUM control + INTEGER :: nn_jctle !: End j indice for the SUM control + INTEGER :: nn_isplt !: number of processors following i + INTEGER :: nn_jsplt !: number of processors following j + + !!---------------------------------------------------------------------- + !! logical units + !!---------------------------------------------------------------------- + INTEGER :: numstp = -1 !: logical unit for time step + INTEGER :: numtime = -1 !: logical unit for timing + INTEGER :: numout = 6 !: logical unit for output print; Set to stdout to ensure any + INTEGER :: numnul = -1 !: logical unit for /dev/null + ! ! early output can be collected; do not change + INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics + INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice + INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) + INTEGER :: numrun = -1 !: logical unit for run statistics + INTEGER :: numdct_in = -1 !: logical unit for transports computing + INTEGER :: numdct_vol = -1 !: logical unit for volume transports output + INTEGER :: numdct_heat = -1 !: logical unit for heat transports output + INTEGER :: numdct_salt = -1 !: logical unit for salt transports output + INTEGER :: numfl = -1 !: logical unit for floats ascii output + INTEGER :: numflo = -1 !: logical unit for floats ascii output + ! + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ref !: character buffer for reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_cfg !: character buffer for configuration specific namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_ref !: character buffer for ice reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_cfg !: character buffer for ice configuration specific namelist + + !!---------------------------------------------------------------------- + !! Run control + !!---------------------------------------------------------------------- + INTEGER :: no_print = 0 !: optional argument of fld_fill (if present, suppress some control print) + INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) +!$AGRIF_DO_NOT_TREAT + INTEGER :: ngrdstop = -1 !: grid number having nstop > 1 +!$AGRIF_END_DO_NOT_TREAT + INTEGER :: nwarn = 0 !: warning flag (=number of warning found during the run) + CHARACTER(lc) :: ctmp1, ctmp2, ctmp3 !: temporary characters 1 to 3 + CHARACTER(lc) :: ctmp4, ctmp5, ctmp6 !: temporary characters 4 to 6 + CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 + CHARACTER(lc) :: ctmp10 !: temporary character 10 + LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) + LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T + LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area + CHARACTER(LEN=lc) :: cxios_context !: context name used in xios + CHARACTER(LEN=lc) :: cr_ocerst_cxt !: context name used in xios to read OCE restart + CHARACTER(LEN=lc) :: cw_ocerst_cxt !: context name used in xios to write OCE restart file + CHARACTER(LEN=lc) :: cr_icerst_cxt !: context name used in xios to read SI3 restart + CHARACTER(LEN=lc) :: cw_icerst_cxt !: context name used in xios to write SI3 restart file + CHARACTER(LEN=lc) :: cr_ablrst_cxt !: context name used in xios to read ABL restart + CHARACTER(LEN=lc) :: cw_ablrst_cxt !: context name used in xios to write ABL restart file + CHARACTER(LEN=lc) :: cr_toprst_cxt !: context name used in xios to read TOP restart + CHARACTER(LEN=lc) :: cw_toprst_cxt !: context name used in xios to write TOP restart file + CHARACTER(LEN=lc) :: cr_sedrst_cxt !: context name used in xios to read SEDIMENT restart + CHARACTER(LEN=lc) :: cw_sedrst_cxt !: context name used in xios to write SEDIMENT restart file + + + + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: in_out_manager.F90 14553 2021-02-26 17:01:43Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!===================================================================== +END MODULE in_out_manager diff --git a/TMP_MY_SRC/iom.F90 b/TMP_MY_SRC/iom.F90 new file mode 100644 index 0000000..8a1b561 --- /dev/null +++ b/TMP_MY_SRC/iom.F90 @@ -0,0 +1,2858 @@ +MODULE iom + !!====================================================================== + !! *** MODULE iom *** + !! Input/Output manager : Library to read input files + !!====================================================================== + !! History : 2.0 ! 2005-12 (J. Belier) Original code + !! 2.0 ! 2006-02 (S. Masson) Adaptation to NEMO + !! 3.0 ! 2007-07 (D. Storkey) Changes to iom_gettime + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add C1D case + !! 3.6 ! 2014-15 DIMG format removed + !! 3.6 ! 2015-15 (J. Harle) Added procedure to read REAL attributes + !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iom_open : open a file read only + !! iom_close : close a file or all files opened by iom + !! iom_get : read a field (interfaced to several routines) + !! iom_varid : get the id of a variable in a file + !! iom_rstput : write a field in a restart file (interfaced to several routines) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE domutl ! + USE flo_oce ! floats module declarations + USE lbclnk ! lateal boundary condition / mpp exchanges + USE iom_def ! iom variables definitions + USE iom_nf90 ! NetCDF format with native NetCDF library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE sbc_oce , ONLY : nn_fsbc, ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1 + USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes +#if defined key_si3 + USE ice , ONLY : jpl +#endif + USE phycst ! physical constants + USE dianam ! build name of file +#if defined key_xios + USE xios +# endif + USE ioipsl, ONLY : ju2ymds ! for calendar + USE crs ! Grid coarsening +#if defined key_top + USE trc, ONLY : profsed +#endif + USE lib_fortran + USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal + USE iom_nf90 + USE netcdf + + IMPLICIT NONE + PUBLIC ! must be public to be able to access iom_def through iom + +#if defined key_xios + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag +#endif + LOGICAL, PUBLIC :: l_iom = .TRUE. !: RK3 iom flag prevent writing at stage 1&2 + PUBLIC iom_init, iom_init_closedef, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_get_var + PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put + PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val + PUBLIC iom_xios_setid + + PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + PRIVATE iom_get_123d + PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp +#if defined key_xios + 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 + PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate + PRIVATE iom_set_rst_context, iom_set_vars_active +# endif + PRIVATE set_xios_context + PRIVATE iom_set_rstw_active + + INTERFACE iom_get + MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + END INTERFACE + INTERFACE iom_getatt + MODULE PROCEDURE iom_g0d_iatt, iom_g1d_iatt, iom_g0d_ratt, iom_g1d_ratt, iom_g0d_catt + END INTERFACE + INTERFACE iom_putatt + MODULE PROCEDURE iom_p0d_iatt, iom_p1d_iatt, iom_p0d_ratt, iom_p1d_ratt, iom_p0d_catt + END INTERFACE + INTERFACE iom_rstput + MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + END INTERFACE + INTERFACE iom_put + MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp + END INTERFACE iom_put + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom.F90 15512 2021-11-15 17:22:03Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_init( cdname, kdid, ld_closedef ) + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + INTEGER , OPTIONAL, INTENT(in) :: kdid + LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef +#if defined key_xios + ! + TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) + TYPE(xios_date) :: start_date + CHARACTER(len=lc) :: clname, cltmpn + INTEGER :: irefyear, irefmonth, irefday + INTEGER :: ji + LOGICAL :: llrst_context ! is context related to restart + LOGICAL :: llrstr, llrstw + INTEGER :: inum + INTEGER :: iln + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds + REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries + LOGICAL :: ll_closedef + LOGICAL :: ll_exist + !!---------------------------------------------------------------------- + ! + ll_closedef = .TRUE. + IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef + ! + ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) ) + ! + clname = TRIM(cdname) + IF ( .NOT. Agrif_Root() ) THEN + iln = INDEX(clname,'/', BACK=.TRUE.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + + CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) + CALL iom_swap( cdname ) + + llrstr = (cdname == cr_ocerst_cxt) .OR. (cdname == cr_icerst_cxt) + llrstr = llrstr .OR. (cdname == cr_ablrst_cxt) + llrstr = llrstr .OR. (cdname == cr_toprst_cxt) + llrstr = llrstr .OR. (cdname == cr_sedrst_cxt) + + llrstw = (cdname == cw_ocerst_cxt) .OR. (cdname == cw_icerst_cxt) + llrstw = llrstw .OR. (cdname == cw_ablrst_cxt) + llrstw = llrstw .OR. (cdname == cw_toprst_cxt) + llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) + + llrst_context = llrstr .OR. llrstw + + ! Calendar type is now defined in xml file + IF (.NOT.(xios_getvar('ref_year' ,irefyear ))) irefyear = 1900 + IF (.NOT.(xios_getvar('ref_month',irefmonth))) irefmonth = 01 + IF (.NOT.(xios_getvar('ref_day' ,irefday ))) irefday = 01 + + SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL + CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + END SELECT + + ! horizontal grid definition + IF(.NOT.llrst_context) CALL set_scalar + ! + IF( cdname == cxios_context ) THEN + CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. ) + CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) + CALL set_grid( "V", glamv, gphiv, .FALSE., .FALSE. ) + CALL set_grid( "W", glamt, gphit, .FALSE., .FALSE. ) + CALL set_grid( "F", glamf, gphif, .FALSE., .FALSE. ) + CALL set_grid_znl( gphit ) + ! + IF( ln_cfmeta ) THEN ! Add additional grid metadata + CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_W", area = REAL( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_F", area = real( e1e2f(Nis0:Nie0, Njs0:Nje0), dp)) + CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) + CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) + CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) + CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) + CALL set_grid_bounds( "F", glamt, gphit, glamf, gphif ) + ENDIF + ENDIF + ! + IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN + CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) + CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) + CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) + CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) + CALL set_grid_znl( gphit_crs ) + ! + CALL dom_grid_glo ! Return to parent grid domain + ! + IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata + CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) + CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) + CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + ENDIF + ENDIF + ! + ! vertical grid definition + IF(.NOT.llrst_context) THEN + CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) + CALL iom_set_axis_attr( "depthf", paxis = gdept_1d ) + + ! ABL + IF( .NOT. ALLOCATED(ght_abl) ) THEN ! force definition for xml files (xios) + ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) ) ! default allocation needed by iom + ght_abl(:) = -1._wp ; ghw_abl(:) = -1._wp + e3t_abl(:) = -1._wp ; e3w_abl(:) = -1._wp + ENDIF + CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) + CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) + + ! Add vertical grid bounds + zt_bnds(2,: ) = gdept_1d(:) + zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) + zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) + zw_bnds(1,: ) = gdepw_1d(:) + zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) + zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) + CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) + CALL iom_set_axis_attr( "depthf", bounds=zw_bnds ) + + ! ABL + za_bnds(1,:) = ghw_abl(1:jpkam1) + za_bnds(2,:) = ghw_abl(2:jpka ) + CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) + za_bnds(1,:) = ght_abl(2:jpka ) + za_bnds(2,:) = ght_abl(2:jpka ) + e3w_abl(2:jpka) + CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) + + CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) +# if defined key_si3 + CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) + ! SIMIP diagnostics (4 main arctic straits) + CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) +# endif +#if defined key_top + IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) +#endif + CALL iom_set_axis_attr( "icbcla", class_num ) + CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... + ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) + INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) + nbasin = 1 + 4 * COUNT( (/ll_exist/) ) + CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) + ENDIF + ! + ! automatic definitions of some of the xml attributs + IF(llrstr) THEN + IF(PRESENT(kdid)) THEN + CALL iom_set_rst_context(.TRUE.) +!set which fields will be read from restart file + CALL iom_set_vars_active(kdid) + ELSE + CALL ctl_stop( 'iom_init:', 'restart read with XIOS: missing pointer to NETCDF file' ) + ENDIF + ELSE IF(llrstw) THEN + CALL iom_set_rstw_file(iom_file(kdid)%name) + ELSE + CALL set_xmlatt + ENDIF + ! + ! set time step length + dtime%second = rn_Dt + CALL xios_set_timestep( dtime ) + ! + ! conditional closure of context definition + IF ( ll_closedef ) CALL iom_init_closedef + ! + DEALLOCATE( zt_bnds, zw_bnds ) + ! +#endif + ! + END SUBROUTINE iom_init + + SUBROUTINE iom_init_closedef(cdname) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE iom_init_closedef *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Closure of context definition + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname +#if defined key_xios + LOGICAL :: llrstw + + llrstw = .FALSE. + IF(PRESENT(cdname)) THEN + llrstw = (cdname == cw_ocerst_cxt) + llrstw = llrstw .OR. (cdname == cw_icerst_cxt) + llrstw = llrstw .OR. (cdname == cw_ablrst_cxt) + llrstw = llrstw .OR. (cdname == cw_toprst_cxt) + llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) + ENDIF + + IF( llrstw ) THEN +!set names of the fields in restart file IF using XIOS to write data + CALL iom_set_rst_context(.FALSE.) + CALL xios_close_context_definition() + ELSE + CALL xios_close_context_definition() + CALL xios_update_calendar( 0 ) + ENDIF +#else + IF( .FALSE. ) WRITE(numout,*) 'iom_init_closedef: should not see this' ! useless statement to avoid compilation warnings +#endif + + END SUBROUTINE iom_init_closedef + + SUBROUTINE iom_set_vars_active(idnum) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_vars_active *** + !! + !! ** Purpose : define filename in XIOS context for reading file, + !! enable variables present in a file for reading with XIOS + !! id of the file is assumed to be rrestart. + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: idnum + +#if defined key_xios + INTEGER :: ndims, nvars, natts, unlimitedDimId, dimlen, xtype,mdims + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + INTEGER :: dimids(4), jv,i, idim + CHARACTER(LEN=256) :: clinfo ! info character + INTEGER, ALLOCATABLE :: indimlens(:) + CHARACTER(LEN=nf90_max_name), ALLOCATABLE :: indimnames(:) + CHARACTER(LEN=nf90_max_name) :: dimname, varname + INTEGER :: iln + CHARACTER(LEN=lc) :: fname + LOGICAL :: lmeta +!metadata in restart file for restart read with XIOS + INTEGER, PARAMETER :: NMETA = 11 + CHARACTER(LEN=lc) :: meta(NMETA) + + + meta(1) = "nav_lat" + meta(2) = "nav_lon" + meta(3) = "nav_lev" + meta(4) = "time_instant" + meta(5) = "time_instant_bounds" + meta(6) = "time_counter" + meta(7) = "time_counter_bounds" + meta(8) = "x" + meta(9) = "y" + meta(10) = "numcat" + meta(11) = "nav_hgt" + + clinfo = ' iom_set_vars_active, file: '//TRIM(iom_file(idnum)%name) + + iln = INDEX( iom_file(idnum)%name, '.nc' ) +!XIOS doee not need .nc + IF(iln > 0) THEN + fname = iom_file(idnum)%name(1:iln-1) + ELSE + fname = iom_file(idnum)%name + ENDIF + +!set name of the restart file and enable available fields + CALL xios_get_handle("file_definition", filegroup_hdl ) + CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') + CALL xios_set_file_attr( "rrestart", name=fname, type="one_file", & + par_access="collective", enabled=.TRUE., mode="read", & + output_freq=xios_timestep ) + + CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, ndims, nvars, natts ), clinfo ) + ALLOCATE(indimlens(ndims), indimnames(ndims)) + CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, unlimitedDimId = unlimitedDimId ), clinfo ) + + DO idim = 1, ndims + CALL iom_nf90_check( nf90_inquire_dimension(iom_file(idnum)%nfid, idim, dimname, dimlen ), clinfo ) + indimlens(idim) = dimlen + indimnames(idim) = dimname + ENDDO + + DO jv =1, nvars + lmeta = .FALSE. + CALL iom_nf90_check( nf90_inquire_variable(iom_file(idnum)%nfid, jv, varname, xtype, ndims, dimids, natts ), clinfo ) + DO i = 1, NMETA + IF(varname == meta(i)) THEN + lmeta = .TRUE. + ENDIF + ENDDO + IF(.NOT.lmeta) THEN + CALL xios_add_child(file_hdl, field_hdl, varname) + mdims = ndims + + IF(ANY(dimids(1:ndims) == unlimitedDimId)) THEN + mdims = mdims - 1 + ENDIF + + IF(mdims == 3) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + domain_ref="grid_N", & + axis_ref=iom_axis(indimlens(dimids(mdims))), & + prec = 8, operation = "instant" ) + ELSEIF(mdims == 2) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + domain_ref="grid_N", prec = 8, & + operation = "instant" ) + ELSEIF(mdims == 1) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + axis_ref=iom_axis(indimlens(dimids(mdims))), & + prec = 8, operation = "instant" ) + ELSEIF(mdims == 0) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + scalar_ref = "grid_scalar", prec = 8, & + operation = "instant" ) + ELSE + WRITE(ctmp1,*) 'iom_set_vars_active: variable ', TRIM(varname) ,' incorrect number of dimensions' + CALL ctl_stop( 'iom_set_vars_active:', ctmp1 ) + ENDIF + ENDIF + ENDDO + DEALLOCATE(indimlens, indimnames) +#endif + END SUBROUTINE iom_set_vars_active + + SUBROUTINE iom_set_rstw_file(cdrst_file) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_file *** + !! + !! ** Purpose : define file name in XIOS context for writing restart + !!--------------------------------------------------------------------- + CHARACTER(len=*) :: cdrst_file +#if defined key_xios + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + +!set name of the restart file and enable available fields + IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ', TRIM(cdrst_file) + CALL xios_get_handle("file_definition", filegroup_hdl ) + CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') + IF(nxioso.eq.1) THEN + CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& + mode="write", output_freq=xios_timestep) + IF(lwp) write(numout,*) 'OPEN ', TRIM(cdrst_file), ' in one_file mode' + ELSE + CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& + mode="write", output_freq=xios_timestep) + IF(lwp) write(numout,*) 'OPEN ', TRIM(cdrst_file), ' in multiple_file mode' + ENDIF + CALL xios_set_file_attr( "wrestart", name=TRIM(cdrst_file)) +#endif + END SUBROUTINE iom_set_rstw_file + + + SUBROUTINE iom_set_rstw_active(sdfield, rd0, rs0, rd1, rs1, rd2, rs2, rd3, rs3) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_active *** + !! + !! ** Purpose : define file name in XIOS context for writing restart + !! enable variables present in restart file for writing + !!--------------------------------------------------------------------- +!sets enabled = .TRUE. for each field in restart file + CHARACTER(len = *), INTENT(IN) :: sdfield + REAL(dp), OPTIONAL, INTENT(IN) :: rd0 + REAL(sp), OPTIONAL, INTENT(IN) :: rs0 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rd1 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rs1 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rd2 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rs2 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3 +#if defined key_xios + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + + CALL xios_get_handle("wrestart", file_hdl) +!define fields for restart context + CALL xios_add_child(file_hdl, field_hdl, sdfield) + + IF(PRESENT(rd3)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", & + axis_ref = iom_axis(size(rd3, 3)), & + prec = 8, operation = "instant" ) + ELSEIF(PRESENT(rs3)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", & + axis_ref = iom_axis(size(rd3, 3)), & + prec = 4, operation = "instant" ) + ELSEIF(PRESENT(rd2)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", prec = 8, & + operation = "instant" ) + ELSEIF(PRESENT(rs2)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", prec = 4, & + operation = "instant" ) + ELSEIF(PRESENT(rd1)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + axis_ref = iom_axis(size(rd1, 1)), & + prec = 8, operation = "instant" ) + ELSEIF(PRESENT(rs1)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + axis_ref = iom_axis(size(rd1, 1)), & + prec = 4, operation = "instant" ) + ELSEIF(PRESENT(rd0)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + scalar_ref = "grid_scalar", prec = 8, & + operation = "instant" ) + ELSEIF(PRESENT(rs0)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + scalar_ref = "grid_scalar", prec = 4, & + operation = "instant" ) + ENDIF +#endif + END SUBROUTINE iom_set_rstw_active + + FUNCTION iom_axis(idlev) result(axis_ref) + !!--------------------------------------------------------------------- + !! *** FUNCTION iom_axis *** + !! + !! ** Purpose : Used for grid definition when XIOS is used to read/write + !! restart. Returns axis corresponding to the number of levels + !! given as an input variable. Axes are defined in routine + !! iom_set_rst_context + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: idlev + CHARACTER(len=lc) :: axis_ref + CHARACTER(len=12) :: str + IF(idlev == jpk) THEN + axis_ref="nav_lev" + ELSEIF(idlev == jpka) THEN + axis_ref="nav_hgt" +#if defined key_si3 + ELSEIF(idlev == jpl) THEN + axis_ref="numcat" +#endif + ELSE + write(str, *) idlev + CALL ctl_stop( 'iom_axis', 'Definition for axis with '//TRIM(ADJUSTL(str))//' levels missing') + ENDIF + END FUNCTION iom_axis + + FUNCTION iom_xios_setid(cdname) result(kid) + !!--------------------------------------------------------------------- + !! *** FUNCTION *** + !! + !! ** Purpose : this function returns first available id to keep information about file + !! sets filename in iom_file structure and sets name + !! of XIOS context depending on cdcomp + !! corresponds to iom_nf90_open + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! File name + INTEGER :: kid ! identifier of the opened file + INTEGER :: jl + + kid = 0 + DO jl = jpmax_files, 1, -1 + IF( iom_file(jl)%nfid == 0 ) kid = jl + ENDDO + + iom_file(kid)%name = TRIM(cdname) + iom_file(kid)%nfid = 1 + iom_file(kid)%nvars = 0 + iom_file(kid)%irec = -1 + + END FUNCTION iom_xios_setid + + SUBROUTINE iom_set_rst_context(ld_rstr) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rst_context *** + !! + !! ** Purpose : Define domain, axis and grid for restart (read/write) + !! context + !! + !!--------------------------------------------------------------------- + LOGICAL, INTENT(IN) :: ld_rstr + INTEGER :: ji +#if defined key_xios + TYPE(xios_domaingroup) :: domaingroup_hdl + TYPE(xios_domain) :: domain_hdl + TYPE(xios_axisgroup) :: axisgroup_hdl + TYPE(xios_axis) :: axis_hdl + TYPE(xios_scalar) :: scalar_hdl + TYPE(xios_scalargroup) :: scalargroup_hdl + + CALL xios_get_handle("domain_definition",domaingroup_hdl) + CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N") + CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr) + + CALL xios_get_handle("axis_definition",axisgroup_hdl) + CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev") +!AGRIF fails to compile when unit= is in call to xios_set_axis_attr +! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") + CALL xios_set_axis_attr( "nav_lev", long_name = "Vertical levels in meters", positive = "down") + CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) +#if defined key_si3 + CALL xios_add_child(axisgroup_hdl, axis_hdl, "numcat") + CALL iom_set_axis_attr( "numcat", (/ (REAL(ji,wp), ji=1,jpl) /) ) +#endif + CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_hgt") + CALL iom_set_axis_attr( "nav_hgt", (/ (REAL(ji,wp), ji=1,jpka) /) ) + CALL xios_get_handle("scalar_definition", scalargroup_hdl) + CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") +#endif + END SUBROUTINE iom_set_rst_context + + + SUBROUTINE set_xios_context(kdid, cdcont) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rst_context *** + !! + !! ** Purpose : set correct XIOS context based on kdid + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kdid ! Identifier of the file + CHARACTER(LEN=lc), INTENT(OUT) :: cdcont ! name of the context for XIOS read/write + + cdcont = "NONE" + + IF(lrxios) THEN + IF(kdid == numror) THEN + cdcont = cr_ocerst_cxt + ELSEIF(kdid == numrir) THEN + cdcont = cr_icerst_cxt + ELSEIF(kdid == numrar) THEN + cdcont = cr_ablrst_cxt + ELSEIF(kdid == numrtr) THEN + cdcont = cr_toprst_cxt + ELSEIF(kdid == numrsr) THEN + cdcont = cr_sedrst_cxt + ENDIF + ENDIF + + IF(lwxios) THEN + IF(kdid == numrow) THEN + cdcont = cw_ocerst_cxt + ELSEIF(kdid == numriw) THEN + cdcont = cw_icerst_cxt + ELSEIF(kdid == numraw) THEN + cdcont = cw_ablrst_cxt + ELSEIF(kdid == numrtw) THEN + cdcont = cw_toprst_cxt + ELSEIF(kdid == numrsw) THEN + cdcont = cw_sedrst_cxt + ENDIF + ENDIF + END SUBROUTINE set_xios_context + + + SUBROUTINE iom_swap( cdname ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_swap *** + !! + !! ** Purpose : swap context between different agrif grid for xmlio_server + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + CHARACTER(len=256) :: clname, cltmpn + INTEGER :: iln +#if defined key_xios + TYPE(xios_context) :: nemo_hdl + + clname = TRIM(cdname) + IF ( .NOT. Agrif_Root() ) THEN + iln = INDEX(clname,'/', BACK=.TRUE.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + ! + CALL xios_get_handle(clname,nemo_hdl) + ! + CALL xios_set_current_context(nemo_hdl) +#endif + ! + END SUBROUTINE iom_swap + + + SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_open *** + !! + !! ** Purpose : open an input file (return 0 if not found) + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! File name + INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file + LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.) + LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) + LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) + INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels + CHARACTER(len=3), INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open + ! + CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] + CHARACTER(LEN=256) :: cltmpn ! tempory name to store clname (in writting mode) + CHARACTER(LEN=10) :: clsuffix ! ".nc" + CHARACTER(LEN=15) :: clcpu ! the cpu number (max jpmax_digits digits) + CHARACTER(LEN=256) :: clinfo ! info character + LOGICAL :: llok ! check the existence + LOGICAL :: llwrt ! local definition of ldwrt + LOGICAL :: llstop ! local definition of ldstop + LOGICAL :: lliof ! local definition of ldiof + INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits) + INTEGER :: iln, ils ! lengths of character + INTEGER :: istop ! + ! local number of points for x,y dimensions + ! position of first local point for x,y dimensions + ! position of last local point for x,y dimensions + ! start halo size for x,y dimensions + ! end halo size for x,y dimensions + !--------------------------------------------------------------------- + ! Initializations and control + ! ============= + kiomid = -1 + clinfo = ' iom_open ~~~ ' + istop = nstop + ! if iom_open is called for the first time: initialize iom_file(:)%nfid to 0 + ! (could be done when defining iom_file in f95 but not in f90) + IF( Agrif_Root() ) THEN + IF( iom_open_init == 0 ) THEN + iom_file(:)%nfid = 0 + iom_open_init = 1 + ENDIF + ENDIF + ! do we read or write the file? + IF( PRESENT(ldwrt) ) THEN ; llwrt = ldwrt + ELSE ; llwrt = .FALSE. + ENDIF + ! do we call ctl_stop if we try to open a non-existing file in read mode? + IF( PRESENT(ldstop) ) THEN ; llstop = ldstop + ELSE ; llstop = .TRUE. + ENDIF + ! are we using interpolation on the fly? + IF( PRESENT(ldiof) ) THEN ; lliof = ldiof + ELSE ; lliof = .FALSE. + ENDIF + ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) + ! ============= + clname = TRIM(cdname) + IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN + iln = INDEX(clname,'/', BACK=.TRUE.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + ! which suffix should we use? + clsuffix = '.nc' + ! Add the suffix if needed + iln = LEN_TRIM(clname) + ils = LEN_TRIM(clsuffix) + IF( iln <= ils .OR. INDEX( TRIM(clname), TRIM(clsuffix), back = .TRUE. ) /= iln - ils + 1 ) & + & clname = TRIM(clname)//TRIM(clsuffix) + cltmpn = clname ! store this name + ! try to find if the file to be opened already exist + ! ============= + INQUIRE( FILE = clname, EXIST = llok ) + IF( .NOT.llok ) THEN + ! we try to add the cpu number to the name + WRITE(clcpu,*) narea-1 + + clcpu = TRIM(ADJUSTL(clcpu)) + iln = INDEX(clname,TRIM(clsuffix), back = .TRUE.) + clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix) + icnt = 0 + INQUIRE( FILE = clname, EXIST = llok ) + ! we try different formats for the cpu number by adding 0 + DO WHILE( .NOT.llok .AND. icnt < jpmax_digits ) + clcpu = "0"//TRIM(clcpu) + clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix) + INQUIRE( FILE = clname, EXIST = llok ) + icnt = icnt + 1 + END DO + ELSE + lxios_sini = .TRUE. + ENDIF + ! Open the NetCDF file + ! ============= + ! do we have some free file identifier? + IF( MINVAL(iom_file(:)%nfid) /= 0 ) & + & CALL ctl_stop( TRIM(clinfo), 'No more free file identifier', 'increase jpmax_files in iom_def' ) + ! if no file was found... + IF( .NOT. llok ) THEN + IF( .NOT. llwrt ) THEN ! we are in read mode + IF( llstop ) THEN ; CALL ctl_stop( TRIM(clinfo), 'File '//TRIM(cltmpn)//'* not found' ) + ELSE ; istop = nstop + 1 ! make sure that istop /= nstop so we don't open the file + ENDIF + ELSE ! we are in write mode so we + clname = cltmpn ! get back the file name without the cpu number + ENDIF + ELSE + IF( llwrt .AND. .NOT. ln_clobber ) THEN ! we stop as we want to write in a new file + CALL ctl_stop( TRIM(clinfo), 'We want to write in a new file but '//TRIM(clname)//' already exists...' ) + istop = nstop + 1 ! make sure that istop /= nstop so we don't open the file + ELSEIF( llwrt ) THEN ! the file exists and we are in write mode with permission to + clname = cltmpn ! overwrite so get back the file name without the cpu number + ENDIF + ENDIF + IF( istop == nstop ) THEN ! no error within this routine + CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp ) + ENDIF + ! + END SUBROUTINE iom_open + + + SUBROUTINE iom_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_close *** + !! + !! ** Purpose : close an input file, or all files opened by iom + !!-------------------------------------------------------------------- + INTEGER, INTENT(inout), OPTIONAL :: kiomid ! iom identifier of the file to be closed + ! ! return 0 when file is properly closed + ! ! No argument: all files opened by iom are closed + + INTEGER :: jf ! dummy loop indices + INTEGER :: i_s, i_e ! temporary integer + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + IF( iom_open_init == 0 ) RETURN ! avoid to use iom_file(jf)%nfid that us not yet initialized + ! + clinfo = ' iom_close ~~~ ' + IF( PRESENT(kiomid) ) THEN + i_s = kiomid + i_e = kiomid + ELSE + i_s = 1 + i_e = jpmax_files + ENDIF + + IF( i_s > 0 ) THEN + DO jf = i_s, i_e + IF( iom_file(jf)%nfid > 0 ) THEN + CALL iom_nf90_close( jf ) + iom_file(jf)%nfid = 0 ! free the id + IF( PRESENT(kiomid) ) kiomid = 0 ! return 0 as id to specify that the file was closed + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok' + ELSEIF( PRESENT(kiomid) ) THEN + WRITE(ctmp1,*) '--->', kiomid + CALL ctl_stop( TRIM(clinfo)//' Invalid file identifier', ctmp1 ) + ENDIF + END DO + ENDIF + ! + END SUBROUTINE iom_close + + + FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_varid *** + !! + !! ** Purpose : get the id of a variable in a file (return 0 if not found) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable + INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension + INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions + LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) + LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) + ! + INTEGER :: iom_varid, iiv, i_nvd + LOGICAL :: ll_fnd + CHARACTER(LEN=100) :: clinfo ! info character + LOGICAL :: llstop ! local definition of ldstop + !!----------------------------------------------------------------------- + iom_varid = 0 ! default definition + ! do we call ctl_stop if we look for non-existing variable? + IF( PRESENT(ldstop) ) THEN ; llstop = ldstop + ELSE ; llstop = .TRUE. + ENDIF + ! + IF( kiomid > 0 ) THEN + clinfo = 'iom_varid, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + IF( iom_file(kiomid)%nfid == 0 ) THEN + CALL ctl_stop( TRIM(clinfo), 'the file is not open' ) + ELSE + ll_fnd = .FALSE. + iiv = 0 + ! + DO WHILE ( .NOT.ll_fnd .AND. iiv < iom_file(kiomid)%nvars ) + iiv = iiv + 1 + ll_fnd = ( TRIM(cdvar) == TRIM(iom_file(kiomid)%cn_var(iiv)) ) + END DO + ! + IF( .NOT.ll_fnd ) THEN + iiv = iiv + 1 + IF( iiv <= jpmax_vars ) THEN + iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) + ELSE + CALL ctl_stop( TRIM(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & + & 'increase the parameter jpmax_vars') + ENDIF + IF( llstop .AND. iom_varid == -1 ) CALL ctl_stop( TRIM(clinfo)//' not found' ) + ELSE + iom_varid = iiv + IF( PRESENT(kdimsz) ) THEN + i_nvd = iom_file(kiomid)%ndims(iiv) + IF( i_nvd <= size(kdimsz) ) THEN + kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,iiv) + ELSE + WRITE(ctmp1,*) i_nvd, size(kdimsz) + CALL ctl_stop( TRIM(clinfo), 'error in kdimsz size'//TRIM(ctmp1) ) + ENDIF + ENDIF + IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) + IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) + ENDIF + ENDIF + ENDIF + ! + END FUNCTION iom_varid + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_get + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out) :: pvar ! read field + REAL(dp) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + ! + INTEGER :: idvar ! variable id + INTEGER :: idmspc ! number of spatial dimensions + INTEGER , DIMENSION(1) :: itime ! record number + CHARACTER(LEN=100) :: clinfo ! info character + CHARACTER(LEN=100) :: clname ! file name + CHARACTER(LEN=1) :: cldmspc ! + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + IF(context == "NONE") THEN ! read data using default library + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + clname = iom_file(kiomid)%name + clinfo = ' iom_g0d, file: '//TRIM(clname)//', var: '//TRIM(cdvar) + ! + IF( kiomid > 0 ) THEN + idvar = iom_varid( kiomid, cdvar ) + IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN + idmspc = iom_file ( kiomid )%ndims( idvar ) + IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 + WRITE(cldmspc , fmt='(i1)') idmspc + IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & + & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & + & 'Use ncwa -a to suppress the unnecessary dimensions' ) + CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) + pvar = ztmp_pvar + ENDIF + ENDIF + ELSE +#if defined key_xios + IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', TRIM(cdvar) + CALL iom_swap(context) + CALL xios_recv_field( TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//TRIM(clname)//', var:'//TRIM(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_sp + + SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out) :: pvar ! read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + ! + INTEGER :: idvar ! variable id + INTEGER :: idmspc ! number of spatial dimensions + INTEGER , DIMENSION(1) :: itime ! record number + CHARACTER(LEN=100) :: clinfo ! info character + CHARACTER(LEN=100) :: clname ! file name + CHARACTER(LEN=1) :: cldmspc ! + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + IF(context == "NONE") THEN ! read data using default library + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + clname = iom_file(kiomid)%name + clinfo = ' iom_g0d, file: '//TRIM(clname)//', var: '//TRIM(cdvar) + ! + IF( kiomid > 0 ) THEN + idvar = iom_varid( kiomid, cdvar ) + IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN + idmspc = iom_file ( kiomid )%ndims( idvar ) + IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 + WRITE(cldmspc , fmt='(i1)') idmspc + IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & + & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & + & 'Use ncwa -a to suppress the unnecessary dimensions' ) + CALL iom_nf90_get( kiomid, idvar, pvar, itime ) + ENDIF + ENDIF + ELSE +#if defined key_xios + IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', TRIM(cdvar) + CALL iom_swap(context) + CALL xios_recv_field( TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//TRIM(clname)//', var:'//TRIM(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_dp + + SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1))) + CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g1d_sp + + + SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount) + ENDIF + END SUBROUTINE iom_g1d_dp + + SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + ENDIF + ENDIF + END SUBROUTINE iom_g2d_sp + + SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + ENDIF + END SUBROUTINE iom_g2d_dp + + SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g3d_sp + + SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + END IF + ENDIF + END SUBROUTINE iom_g3d_dp + + !!---------------------------------------------------------------------- + + SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & + & cd_type, psgn, kfill, kstart, kcount ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_get_123d *** + !! + !! ** Purpose : read a 1D/2D/3D variable + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis + ! + LOGICAL :: llok ! true if ok! + INTEGER :: jl ! loop on number of dimension + INTEGER :: idom ! type of domain + INTEGER :: idvar ! id of the variable + INTEGER :: inbdim ! number of dimensions of the variable + INTEGER :: idmspc ! number of spatial dimensions + INTEGER :: itime ! record number + INTEGER :: istop ! temporary value of nstop + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER :: ji, jj ! loop counters + INTEGER :: irankpv ! + INTEGER :: ind1, ind2 ! substring index + INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis + INTEGER, DIMENSION(jpmax_dims) :: icnt ! number of value to read along each axis + INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable + INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable + REAL(dp) :: zscf, zofs ! sacle_factor and add_offset + REAL(wp) :: zsgn ! local value of psgn + INTEGER :: itmp ! temporary integer + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: clname ! file name + CHARACTER(LEN=1) :: clrankpv, cldmspc ! + CHARACTER(LEN=1) :: cl_type ! local value of cd_type + LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. + INTEGER :: inlev ! number of levels for 3D data + REAL(dp) :: gma, gmi + !--------------------------------------------------------------------- + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + inlev = -1 + IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) + ! + idom = kdom + istop = nstop + ! + IF(context == "NONE") THEN + clname = iom_file(kiomid)%name ! esier to read + clinfo = ' iom_get_123d, file: '//TRIM(clname)//', var: '//TRIM(cdvar) + ! check kcount and kstart optionals parameters... + IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(TRIM(clinfo), 'kcount present needs kstart present') + IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(TRIM(clinfo), 'kstart present needs kcount present') + IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) & + & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy') + IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) & + & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present') + ! + ! Search for the variable in the data base (eventually actualize data) + ! + idvar = iom_varid( kiomid, cdvar ) + IF( idvar > 0 ) THEN + ! + idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way + inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file + idmspc = inbdim ! number of spatial dimensions in the file + IF( iom_file(kiomid)%luld(idvar) ) idmspc = inbdim - 1 + IF( idmspc > 3 ) CALL ctl_stop(TRIM(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') + ! + ! Identify the domain in case of jpdom_auto definition + IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN + idom = jpdom_global ! default + ! else: if the file name finishes with _xxxx.nc with xxxx any number + ind1 = INDEX( clname, '_', back = .TRUE. ) + 1 + ind2 = INDEX( clname, '.', back = .TRUE. ) - 1 + IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF + ENDIF + ! + ! check the consistency between input array and data rank in the file + ! + ! initializations + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) ) + WRITE(clrankpv, fmt='(i1)') irankpv + WRITE(cldmspc , fmt='(i1)') idmspc + ! + IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... + IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: + llok = inlev == 1 ! -> 3rd dimension must be equal to 1 + ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: + llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 + ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: + llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 + ELSE + llok = .FALSE. + ENDIF + IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & + & '=> cannot read a true '//clrankpv//'D array from this file...' ) + ELSEIF( idmspc == irankpv ) THEN + IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & + & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) + ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... + IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN + CALL ctl_warn( TRIM(clinfo), '2D array input but 3 spatial dimensions in the file...' , & + & 'As the size of the z dimension is 1 and as we try to read the first record, ', & + & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) + idmspc = idmspc - 1 + !!GS: possibility to read 3D ABL atmopsheric forcing and use 1st level to force BULK simulation + !ELSE + ! CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,', & + ! & 'we do not accept data with '//cldmspc//' spatial dimensions' , & + ! & 'Use ncwa -a to suppress the unnecessary dimensions' ) + ENDIF + ENDIF + ! + ! definition of istart and icnt + ! + icnt (:) = 1 ! default definition (simple way to deal with special cases listed above) + istart(:) = 1 ! default definition (simple way to deal with special cases listed above) + istart(idmspc+1) = itime ! temporal dimenstion + ! + IF( idom == jpdom_unknown ) THEN + IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN + istart(1:idmspc) = kstart(1:idmspc) + icnt (1:idmspc) = kcount(1:idmspc) + ELSE + icnt (1:idmspc) = idimsz(1:idmspc) + ENDIF + ELSE ! not a 1D array as pv_r1d requires jpdom_unknown + ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 + IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) + icnt(1:2) = (/ Ni_0, Nj_0 /) + IF( PRESENT(pv_r3d) ) THEN + IF( idom == jpdom_auto_xy ) THEN + istart(3) = kstart(3) + icnt (3) = kcount(3) + ELSE + icnt (3) = inlev + ENDIF + ENDIF + ENDIF + ! + ! check that istart and icnt can be used with this file + !- + DO jl = 1, jpmax_dims + itmp = istart(jl)+icnt(jl)-1 + IF( itmp > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN + WRITE( ctmp1, FMT="('(istart(', i1, ') + icnt(', i1, ') - 1) = ', i5)" ) jl, jl, itmp + WRITE( ctmp2, FMT="(' is larger than idimsz(', i1,') = ', i5)" ) jl, idimsz(jl) + CALL ctl_stop( TRIM(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 ) + ENDIF + END DO + ! + ! check that icnt matches the input array + !- + IF( idom == jpdom_unknown ) THEN + IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d) + IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d) + IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d) + ctmp1 = 'd' + ELSE + IF( irankpv == 2 ) THEN + ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' + ENDIF + IF( irankpv == 3 ) THEN + ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' + ENDIF + ENDIF + DO jl = 1, irankpv + WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) + IF( ishape(jl) /= icnt(jl) ) CALL ctl_stop( TRIM(clinfo), 'size(pv_r'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) ) + END DO + + ENDIF + + ! read the data + !- + IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point... + ! + ! find the right index of the array to be read + IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 + ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) + ENDIF + + CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) + + IF( istop == nstop ) THEN ! no additional errors until this point... + IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) + + cl_type = 'T' + IF( PRESENT(cd_type) ) cl_type = cd_type + zsgn = 1._wp + IF( PRESENT(psgn ) ) zsgn = psgn + !--- overlap areas and extra hallows (mpp) + IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) + ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) + ENDIF + ! + ELSE + ! return if istop == nstop is false + RETURN + ENDIF + ELSE + ! return if statment idvar > 0 .AND. istop == nstop is false + RETURN + ENDIF + ! + ELSE ! read using XIOS. Only if key_xios is defined +#if defined key_xios +!would be good to be able to check which context is active and swap only if current is not restart + idvar = iom_varid( kiomid, cdvar ) + CALL iom_swap(context) + zsgn = 1._wp + IF( PRESENT(psgn ) ) zsgn = psgn + cl_type = 'T' + IF( PRESENT(cd_type) ) cl_type = cd_type + + IF( PRESENT(pv_r3d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) + CALL xios_recv_field( TRIM(cdvar), pv_r3d(:, :, :)) + IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) + ENDIF + ELSEIF( PRESENT(pv_r2d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) + CALL xios_recv_field( TRIM(cdvar), pv_r2d(:, :)) + IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) + ENDIF + ELSEIF( PRESENT(pv_r1d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) + CALL xios_recv_field( TRIM(cdvar), pv_r1d) + ENDIF + CALL iom_swap(cxios_context) +#else + istop = istop + 1 + clinfo = 'Can not use XIOS in iom_get_123d, file: '//TRIM(clname)//', var:'//TRIM(cdvar) +#endif + ENDIF + + !--- Apply scale_factor and offset + zscf = iom_file(kiomid)%scf(idvar) ! scale factor + zofs = iom_file(kiomid)%ofs(idvar) ! offset + IF( PRESENT(pv_r1d) ) THEN + IF( zscf /= 1._wp ) pv_r1d(:) = pv_r1d(:) * zscf + IF( zofs /= 0._wp ) pv_r1d(:) = pv_r1d(:) + zofs + ELSEIF( PRESENT(pv_r2d) ) THEN + IF( zscf /= 1._wp) pv_r2d(:,:) = pv_r2d(:,:) * zscf + IF( zofs /= 0._wp) pv_r2d(:,:) = pv_r2d(:,:) + zofs + ELSEIF( PRESENT(pv_r3d) ) THEN + IF( zscf /= 1._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf + IF( zofs /= 0._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs + ENDIF + ! + END SUBROUTINE iom_get_123d + + SUBROUTINE iom_get_var( cdname, z2d) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(jpi,jpj) :: z2d +#if defined key_xios + IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN + z2d(:,:) = 0._wp + CALL xios_recv_field( cdname, z2d) + ENDIF +#else + IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_get_var + + + FUNCTION iom_getszuld ( kiomid ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_getszuld *** + !! + !! ** Purpose : get the size of the unlimited dimension in a file + !! (return -1 if not found) + !!----------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiomid ! file Identifier + ! + INTEGER :: iom_getszuld + !!----------------------------------------------------------------------- + iom_getszuld = -1 + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%iduld > 0 ) iom_getszuld = iom_file(kiomid)%lenuld + ENDIF + END FUNCTION iom_getszuld + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_chkatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! Name of the attribute + LOGICAL , INTENT( out) :: llok ! Error code + INTEGER , INTENT( out), OPTIONAL :: ksize ! Size of the attribute array + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_chkatt( kiomid, cdatt, llok, ksize=ksize, cdvar=cdvar ) + ENDIF + ! + END SUBROUTINE iom_chkatt + + !!---------------------------------------------------------------------- + !! INTERFACE iom_getatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT( out) :: katt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_iatt + + SUBROUTINE iom_g1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT( out) :: katt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_iatt + + SUBROUTINE iom_g0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT( out) :: patt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_ratt + + SUBROUTINE iom_g1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT( out) :: patt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_ratt + + SUBROUTINE iom_g0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT( out) :: cdatt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_putatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT(in ) :: katt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_iatt + + SUBROUTINE iom_p1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT(in ) :: katt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_iatt + + SUBROUTINE iom_p0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT(in ) :: patt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_ratt + + SUBROUTINE iom_p1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT(in ) :: patt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_ratt + + SUBROUTINE iom_p0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT(in ) :: cdatt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_rstput + !!---------------------------------------------------------------------- + SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rs0 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_sp + + SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rd0 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_dp + + + SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rs1 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_sp + + SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rd1 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_dp + + + SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rs2 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_sp + + SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rd2 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_dp + + + SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rs3 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_sp + + SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_put(TRIM(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',TRIM(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( TRIM(cdvar), rd3 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_dp + + + + SUBROUTINE iom_delay_rst( cdaction, cdcpnt, kncid ) + !!--------------------------------------------------------------------- + !! Routine iom_delay_rst: used read/write restart related to mpp_delay + !! + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdaction ! + CHARACTER(len=*), INTENT(in ) :: cdcpnt + INTEGER , INTENT(in ) :: kncid + ! + INTEGER :: ji + INTEGER :: indim + LOGICAL :: llattexist + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zreal1d + !!--------------------------------------------------------------------- + ! + ! =================================== + IF( TRIM(cdaction) == 'READ' ) THEN ! read restart related to mpp_delay ! + ! =================================== + DO ji = 1, nbdelay + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + CALL iom_chkatt( kncid, 'DELAY_'//c_delaylist(ji), llattexist, indim ) + IF( llattexist ) THEN + ALLOCATE( todelay(ji)%z1d(indim) ) + CALL iom_getatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ndelayid(ji) = 0 ! set to 0 to specify that the value was read in the restart + ENDIF + ENDIF + END DO + ! ==================================== + ELSE ! write restart related to mpp_delay ! + ! ==================================== + DO ji = 1, nbdelay ! save only ocean delayed global communication variables + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + IF( ASSOCIATED(todelay(ji)%z1d) ) THEN + CALL mpp_delay_rcv(ji) ! make sure %z1d is received + CALL iom_putatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ENDIF + ENDIF + END DO + ! + ENDIF + + END SUBROUTINE iom_delay_rst + + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_put + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_sp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(sp) , INTENT(in) :: pfield0d + !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_xios +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_sp + + SUBROUTINE iom_p0d_dp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(dp) , INTENT(in) :: pfield0d +!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_xios +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_dp + + + SUBROUTINE iom_p1d_sp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_xios + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_sp + + SUBROUTINE iom_p1d_dp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_xios + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_dp + + SUBROUTINE iom_p2d_sp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield2d) == 1 ) THEN + CALL xios_send_field( cdname, pfield2d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield2d ) + ENDIF +#else + WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p2d_sp + + SUBROUTINE iom_p2d_dp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield2d) == 1 ) THEN + CALL xios_send_field( cdname, pfield2d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield2d ) + ENDIF +#else + WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p2d_dp + + SUBROUTINE iom_p3d_sp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield3d) == 1 ) THEN + CALL xios_send_field( cdname, pfield3d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield3d ) + ENDIF +#else + WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p3d_sp + + SUBROUTINE iom_p3d_dp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield3d) == 1 ) THEN + CALL xios_send_field( cdname, pfield3d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield3d ) + ENDIF +#else + WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p3d_dp + + SUBROUTINE iom_p4d_sp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield4d) == 1 ) THEN + CALL xios_send_field( cdname, pfield4d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield4d ) + ENDIF +#else + WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p4d_sp + + SUBROUTINE iom_p4d_dp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield4d) == 1 ) THEN + CALL xios_send_field( cdname, pfield4d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield4d ) + ENDIF +#else + WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p4d_dp + +#if defined key_xios + !!---------------------------------------------------------------------- + !! 'key_xios' XIOS interface + !!---------------------------------------------------------------------- + + SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, & + & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & + & ntiles, tile_ibegin, tile_jbegin, tile_ni, tile_nj, & + & tile_data_ibegin, tile_data_jbegin, tile_data_ni, tile_data_nj, & + & nvertex, bounds_lon, bounds_lat, area ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj + INTEGER, DIMENSION(:) , OPTIONAL, INTENT(in) :: tile_ibegin, tile_jbegin, tile_ni, tile_nj + INTEGER, DIMENSION(:) , OPTIONAL, INTENT(in) :: tile_data_ibegin, tile_data_jbegin, tile_data_ni, tile_data_nj + INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj + INTEGER , OPTIONAL, INTENT(in) :: nvertex, ntiles + REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue + REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area + LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask + !!---------------------------------------------------------------------- + ! + IF( xios_is_valid_domain (cdid) ) THEN + CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & + & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & + & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & + & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & + & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & + & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & + & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') + ENDIF + IF( xios_is_valid_domaingroup(cdid) ) THEN + CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & + & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & + & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & + & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & + & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & + & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & + & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) + ENDIF + ! + CALL xios_solve_inheritance() + ! + END SUBROUTINE iom_set_domain_attr + + + SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in) :: cdid + INTEGER , INTENT(in) :: ibegin, jbegin, ni, nj + ! + TYPE(xios_gridgroup) :: gridgroup_hdl + TYPE(xios_grid) :: grid_hdl + TYPE(xios_domain) :: domain_hdl + TYPE(xios_axis) :: axis_hdl + CHARACTER(LEN=64) :: cldomrefid ! domain_ref name + CHARACTER(len=1) :: cl1 ! last character of this name + !!---------------------------------------------------------------------- + ! + IF( xios_is_valid_zoom_domain(cdid) ) THEN + ! define the zoom_domain attributs + CALL xios_set_zoom_domain_attr( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj ) + ! define a new 2D grid with this new domain + CALL xios_get_handle("grid_definition", gridgroup_hdl ) + CALL xios_add_child(gridgroup_hdl, grid_hdl, TRIM(cdid)//'_2D' ) ! add a new 2D grid to grid_definition + CALL xios_add_child(grid_hdl, domain_hdl, TRIM(cdid) ) ! add its domain + ! define a new 3D grid with this new domain + CALL xios_add_child(gridgroup_hdl, grid_hdl, TRIM(cdid)//'_3D' ) ! add a new 3D grid to grid_definition + CALL xios_add_child(grid_hdl, domain_hdl, TRIM(cdid) ) ! add its domain + ! vertical axis + cl1 = cdid(LEN_TRIM(cdid):) ! last letter of cdid + cl1 = CHAR(ICHAR(cl1)+32) ! from upper to lower case + CALL xios_add_child(grid_hdl, axis_hdl, 'depth'//cl1) ! add its axis + ENDIF + ! + END SUBROUTINE iom_set_zoom_domain_attr + + + SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis + REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds + !!---------------------------------------------------------------------- + IF( PRESENT(paxis) ) THEN + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) + ENDIF + IF( PRESENT(bounds) ) THEN + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) + ELSE + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) + END IF + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_axis_attr + + + SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_op + TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_offset + !!---------------------------------------------------------------------- + IF( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) + IF( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_field_attr + + + SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: name, name_suffix + !!---------------------------------------------------------------------- + IF( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) + IF( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_file_attr + + + SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdid + CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix + TYPE(xios_duration), OPTIONAL , INTENT(out) :: output_freq + LOGICAL :: llexist1,llexist2,llexist3 + !--------------------------------------------------------------------- + IF( PRESENT( name ) ) name = '' ! default values + IF( PRESENT( name_suffix ) ) name_suffix = '' + IF( PRESENT( output_freq ) ) output_freq = xios_duration(0,0,0,0,0,0) + IF( xios_is_valid_file (cdid) ) THEN + CALL xios_solve_inheritance() + CALL xios_is_defined_file_attr ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) + IF(llexist1) CALL xios_get_file_attr ( cdid, name = name ) + IF(llexist2) CALL xios_get_file_attr ( cdid, name_suffix = name_suffix ) + IF(llexist3) CALL xios_get_file_attr ( cdid, output_freq = output_freq ) + ENDIF + IF( xios_is_valid_filegroup(cdid) ) THEN + CALL xios_solve_inheritance() + CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) + IF(llexist1) CALL xios_get_filegroup_attr( cdid, name = name ) + IF(llexist2) CALL xios_get_filegroup_attr( cdid, name_suffix = name_suffix ) + IF(llexist3) CALL xios_get_filegroup_attr( cdid, output_freq = output_freq ) + ENDIF + END SUBROUTINE iom_get_file_attr + + + SUBROUTINE iom_set_grid_attr( cdid, mask ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask + !!---------------------------------------------------------------------- + IF( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) + IF( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_grid_attr + + SUBROUTINE iom_setkt( kt, cdname ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + CHARACTER(LEN=*), INTENT(in) :: cdname + !!---------------------------------------------------------------------- + CALL iom_swap( cdname ) ! swap to cdname context + CALL xios_update_calendar(kt) + IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( cxios_context ) ! return back to nemo context + END SUBROUTINE iom_setkt + + SUBROUTINE iom_context_finalize( cdname ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in) :: cdname + CHARACTER(LEN=120) :: clname + CHARACTER(LEN=256) :: cltmpn ! tempory name to store clname (in writting mode) + INTEGER :: iln + !!---------------------------------------------------------------------- + clname = TRIM(cdname) + IF ( .NOT. Agrif_Root() ) THEN + iln = INDEX(clname,'/', BACK=.TRUE.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + + IF( xios_is_valid_context(clname) ) THEN + CALL iom_swap( cdname ) ! swap to cdname context + CALL xios_context_finalize() ! finalize the context + IF( cdname /= cxios_context ) CALL iom_swap( cxios_context ) ! return back to nemo context + ENDIF + ! + END SUBROUTINE iom_context_finalize + + + SUBROUTINE set_grid( cdgrd, plon, plat, ldxios, ldrxios ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid *** + !! + !! ** Purpose : define horizontal grids + !!---------------------------------------------------------------------- + CHARACTER(LEN=1) , INTENT(in) :: cdgrd + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat + ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zmask + INTEGER :: jn + INTEGER, DIMENSION(nijtile) :: ini, inj, idb + LOGICAL, INTENT(IN) :: ldxios, ldrxios + !!---------------------------------------------------------------------- + ! + CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) + CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni=jpi, data_jbegin = -nn_hls, data_nj=jpj) + + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ni_glo = Ni0glo, nj_glo = Nj0glo, & + & ibegin = mig0(Nis0) - 1, jbegin = mjg0(Njs0) - 1, ni = Ni_0, nj = Nj_0) + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", data_dim=2, data_ibegin = 0, data_ni=Ni_0, data_jbegin = 0, data_nj=Nj_0) + + IF( ln_tile ) THEN + DO jn = 1, nijtile + ini(jn) = ntei_a(jn) - ntsi_a(jn) + 1 ! Tile size in i and j + inj(jn) = ntej_a(jn) - ntsj_a(jn) + 1 + idb(jn) = -nn_hls ! Tile data offset (halo size) + END DO + + ! Tile_[ij]begin are defined with respect to the processor data domain, so data_[ij]begin is added + CALL iom_set_domain_attr("grid_"//cdgrd, ntiles=nijtile, & + & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ni=ini(:), tile_nj=inj(:), & + & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & + & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ntiles=nijtile, & + & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ni=ini(:), tile_nj=inj(:), & + & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & + & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) + ENDIF + +!don't define lon and lat for restart reading context. + IF ( .NOT.ldrxios ) & + CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & + & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) + ! + IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN + ! mask land points, keep values on coast line -> specific mask for U, V and W points + SELECT CASE ( cdgrd ) + CASE('T') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + CASE('U') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0+1:Nie0+1, Njs0 :Nje0 ,:) + CASE('V') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0 :Nie0 , Njs0+1:Nje0+1,:) + CASE('F') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0 :Nie0 , Njs0+1:Nje0+1,:) & + & + tmask(Nis0+1:Nie0+1, Njs0:Nje0,:) + tmask(Nis0+1:Nie0+1, Njs0+1:Nje0+1,:) + CASE('W') ; zmask(:,:,2:jpk) = tmask(Nis0:Nie0, Njs0:Nje0,1:jpkm1) + tmask(Nis0:Nie0, Njs0:Nje0,2:jpk) + zmask(:,:,1 ) = tmask(Nis0:Nie0, Njs0:Nje0,1) + END SELECT + ! + CALL iom_set_domain_attr( "grid_"//cdgrd , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. ) + CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D" , mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) + CALL iom_set_domain_attr( "grid_"//cdgrd//"_inner" , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. ) + CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D_inner", mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) + ENDIF + ! + END SUBROUTINE set_grid + + SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid_bounds *** + !! + !! ** Purpose : define horizontal grid corners + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=1) , INTENT(in) :: cdgrd + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coord. of a contiguous vertex of cell (i,j) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) + ! + INTEGER :: ji, jj, jn + INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) + ! ! represents the + ! bottom-left corner of + ! cell (i,j) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells + !!---------------------------------------------------------------------- + ! + ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) + ! + ! Offset of coordinate representing bottom-left corner + SELECT CASE ( TRIM(cdgrd) ) + CASE ('T', 'W') ; icnr = -1 ; jcnr = -1 + CASE ('U') ; icnr = 0 ; jcnr = -1 + CASE ('V') ; icnr = -1 ; jcnr = 0 + CASE ('F') ; icnr = 0 ; jcnr = 0 + END SELECT + ! + z_fld(:,:) = 1._wp + CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold + ! + ! Cell vertices that can be defined + DO_2D( 0, 0, 0, 0 ) + z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left + z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right + z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right + z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left + z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left + z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right + z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right + z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left + END_2D + ! + DO_2D( 0, 0, 0, 0 ) + IF( z_fld(ji,jj) == -1. ) THEN + z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) + z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) + z_bnds(:,ji,jj,:) = z_rot(:,:) + ENDIF + END_2D + ! + CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & + & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) + ! + DEALLOCATE( z_bnds, z_fld, z_rot ) + ! + END SUBROUTINE set_grid_bounds + + SUBROUTINE set_grid_znl( plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid_znl *** + !! + !! ** Purpose : define grids for zonal mean + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat + ! + INTEGER :: ix, iy + REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon + !!---------------------------------------------------------------------- + ! + ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp + ! +! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) + CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) + CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) + CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) + CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & + & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) + CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo) + ! + CALL iom_update_file_name('ptr') + ! + END SUBROUTINE set_grid_znl + + + SUBROUTINE set_scalar + !!---------------------------------------------------------------------- + !! *** ROUTINE set_scalar *** + !! + !! ** Purpose : define fake grids for scalar point + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(1) :: zz = 1. + !!---------------------------------------------------------------------- + ! + CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) + CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) + ! + zz = REAL( narea, wp ) + CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) + ! + END SUBROUTINE set_scalar + + + SUBROUTINE set_xmlatt + !!---------------------------------------------------------------------- + !! *** ROUTINE set_xmlatt *** + !! + !! ** Purpose : automatic definitions of some of the xml attributs... + !! + !!---------------------------------------------------------------------- + CHARACTER(len=1),DIMENSION( 3) :: clgrd ! suffix name + CHARACTER(len=256) :: clsuff ! suffix name + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=2) :: cl2 ! 2 characters + CHARACTER(len=3) :: cl3 ! 3 characters + INTEGER :: ji, jg ! loop counters + INTEGER :: ix, iy ! i-,j- index + REAL(wp) ,DIMENSION(11) :: zlontao ! longitudes of tao moorings + REAL(wp) ,DIMENSION( 7) :: zlattao ! latitudes of tao moorings + REAL(wp) ,DIMENSION( 4) :: zlonrama ! longitudes of rama moorings + REAL(wp) ,DIMENSION(11) :: zlatrama ! latitudes of rama moorings + REAL(wp) ,DIMENSION( 3) :: zlonpira ! longitudes of pirata moorings + REAL(wp) ,DIMENSION( 9) :: zlatpira ! latitudes of pirata moorings + TYPE(xios_duration) :: f_op, f_of + !!---------------------------------------------------------------------- + ! + ! frequency of the call of iom_put (attribut: freq_op) + f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = 0 ; CALL iom_set_field_attr('trendT_even' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ABL' , freq_op=f_op, freq_offset=f_of) + + ! output file names (attribut: name) + DO ji = 1, 9 + WRITE(cl1,'(i1)') ji + CALL iom_update_file_name('file'//cl1) + END DO + DO ji = 1, 99 + WRITE(cl2,'(i2.2)') ji + CALL iom_update_file_name('file'//cl2) + END DO + DO ji = 1, 999 + WRITE(cl3,'(i3.3)') ji + CALL iom_update_file_name('file'//cl3) + END DO + + ! Zooms... + clgrd = (/ 'T', 'U', 'W' /) + DO jg = 1, SIZE(clgrd) ! grid type + cl1 = clgrd(jg) + ! Equatorial section (attributs: jbegin, ni, name_suffix) + CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) + CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) + CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) + CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') + CALL iom_update_file_name('Eq'//cl1) + END DO + ! TAO moorings (attributs: ibegin, jbegin, name_suffix) + zlontao = (/ 137.0, 147.0, 156.0, 165.0, -180.0, -170.0, -155.0, -140.0, -125.0, -110.0, -95.0 /) + zlattao = (/ -8.0, -5.0, -2.0, 0.0, 2.0, 5.0, 8.0 /) + CALL set_mooring( zlontao, zlattao ) + ! RAMA moorings (attributs: ibegin, jbegin, name_suffix) + zlonrama = (/ 55.0, 67.0, 80.5, 90.0 /) + zlatrama = (/ -16.0, -12.0, -8.0, -4.0, -1.5, 0.0, 1.5, 4.0, 8.0, 12.0, 15.0 /) + CALL set_mooring( zlonrama, zlatrama ) + ! PIRATA moorings (attributs: ibegin, jbegin, name_suffix) + zlonpira = (/ -38.0, -23.0, -10.0 /) + zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) + CALL set_mooring( zlonpira, zlatpira ) + ! + END SUBROUTINE set_xmlatt + + + SUBROUTINE set_mooring( plon, plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_mooring *** + !! + !! ** Purpose : automatic definitions of moorings xml attributs... + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat ! longitudes/latitudes oft the mooring + ! +!!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name + CHARACTER(len=1),DIMENSION(1) :: clgrd = (/ 'T' /) ! suffix name + CHARACTER(len=256) :: clname ! file name + CHARACTER(len=256) :: clsuff ! suffix name + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=6) :: clon,clat ! name of longitude, latitude + INTEGER :: ji, jj, jg ! loop counters + INTEGER :: ix, iy ! i-,j- index + REAL(wp) :: zlon, zlat + !!---------------------------------------------------------------------- + DO jg = 1, SIZE(clgrd) + cl1 = clgrd(jg) + DO ji = 1, SIZE(plon) + DO jj = 1, SIZE(plat) + zlon = plon(ji) + zlat = plat(jj) + ! modifications for RAMA moorings + IF( zlon == 67. .AND. zlat == 15. ) zlon = 65. + IF( zlon == 90. .AND. zlat <= -4. ) zlon = 95. + IF( zlon == 95. .AND. zlat == -4. ) zlat = -5. + ! modifications for PIRATA moorings + IF( zlon == -38. .AND. zlat == -19. ) zlon = -34. + IF( zlon == -38. .AND. zlat == -14. ) zlon = -32. + IF( zlon == -38. .AND. zlat == -8. ) zlon = -30. + IF( zlon == -38. .AND. zlat == 0. ) zlon = -35. + IF( zlon == -23. .AND. zlat == 20. ) zlat = 21. + IF( zlon == -10. .AND. zlat == -14. ) zlat = -10. + IF( zlon == -10. .AND. zlat == -8. ) zlat = -6. + IF( zlon == -10. .AND. zlat == 4. ) THEN ; zlon = 0. ; zlat = 0. ; ENDIF + CALL dom_ngb( zlon, zlat, ix, iy, cl1 ) + IF( zlon >= 0. ) THEN + IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT( zlon), 'e' + ELSE ; WRITE(clon, '(f5.1,a)') zlon , 'e' + ENDIF + ELSE + IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT(-zlon), 'w' + ELSE ; WRITE(clon, '(f5.1,a)') -zlon , 'w' + ENDIF + ENDIF + IF( zlat >= 0. ) THEN + IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT( zlat), 'n' + ELSE ; WRITE(clat, '(f4.1,a)') zlat , 'n' + ENDIF + ELSE + IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT(-zlat), 's' + ELSE ; WRITE(clat, '(f4.1,a)') -zlat , 's' + ENDIF + ENDIF + clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) + CALL iom_set_zoom_domain_attr(TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1, ni=1, nj=1) + + CALL iom_get_file_attr (TRIM(clname)//cl1, name_suffix = clsuff ) + CALL iom_set_file_attr (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) + CALL iom_update_file_name(TRIM(clname)//cl1) + END DO + END DO + END DO + + END SUBROUTINE set_mooring + + + SUBROUTINE iom_update_file_name( cdid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iom_update_file_name *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + ! + CHARACTER(LEN=256) :: clname, cltmpn + CHARACTER(LEN=20) :: clfreq + CHARACTER(LEN=20) :: cldate + INTEGER :: idx + INTEGER :: jn, iln + INTEGER :: itrlen + INTEGER :: iyear, imonth, iday, isec + REAL(wp) :: zsec + LOGICAL :: llexist + TYPE(xios_duration) :: output_freq + !!---------------------------------------------------------------------- + ! + DO jn = 1, 2 + ! + output_freq = xios_duration(0,0,0,0,0,0) + IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = output_freq ) + IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) + ! + IF ( TRIM(clname) /= '' ) THEN + ! + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + DO WHILE ( idx /= 0 ) + clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname)) + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + END DO + ! + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + DO WHILE ( idx /= 0 ) + IF ( output_freq%timestep /= 0) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%second /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%second),'s' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%minute /= 0 ) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%minute),'mi' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%hour /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%day /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%month /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%year /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE + CALL ctl_stop('error in the name of file id '//TRIM(cdid), & + & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) + ENDIF + clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + END DO + ! + idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday - rn_Dt / rday ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname)) + idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') + END DO + ! + idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday - rn_Dt / rday, ldfull = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname)) + idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') + END DO + ! + idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname)) + idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') + END DO + ! + idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname)) + idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') + END DO + ! + IF( (jn ==1).AND.(.NOT. Agrif_Root())) THEN + iln = INDEX(clname,'/', BACK=.TRUE.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) + IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) + ! + ENDIF + ! + END DO + ! + END SUBROUTINE iom_update_file_name + + + FUNCTION iom_sdate( pjday, ld24, ldfull ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iom_sdate *** + !! + !! ** Purpose : send back the date corresponding to the given julian day + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: pjday ! julian day + LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 + LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss + ! + CHARACTER(LEN=20) :: iom_sdate + CHARACTER(LEN=50) :: clfmt ! format used to write the date + INTEGER :: iyear, imonth, iday, ihour, iminute, isec + REAL(wp) :: zsec + LOGICAL :: ll24, llfull + !!---------------------------------------------------------------------- + ! + IF( PRESENT(ld24) ) THEN ; ll24 = ld24 + ELSE ; ll24 = .FALSE. + ENDIF + ! + IF( PRESENT(ldfull) ) THEN ; llfull = ldfull + ELSE ; llfull = .FALSE. + ENDIF + ! + CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) + isec = NINT(zsec) + ! + IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day + CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) + isec = 86400 + ENDIF + ! + IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date + ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 + ENDIF + ! +!$AGRIF_DO_NOT_TREAT + ! needed in the conv + IF( llfull ) THEN + clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" + ihour = isec / 3600 + isec = MOD(isec, 3600) + iminute = isec / 60 + isec = MOD(isec, 60) + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec ! date of the end of run + ELSE + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run + ENDIF +!$AGRIF_END_DO_NOT_TREAT + ! + END FUNCTION iom_sdate + +#else + !!---------------------------------------------------------------------- + !! NOT 'key_xios' a few dummy routines + !!---------------------------------------------------------------------- + SUBROUTINE iom_setkt( kt, cdname ) + INTEGER , INTENT(in):: kt + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) kt, cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_setkt + + SUBROUTINE iom_context_finalize( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_context_finalize + + SUBROUTINE iom_update_file_name( cdid ) + CHARACTER(LEN=*), INTENT(in) :: cdid + IF( .FALSE. ) WRITE(numout,*) cdid ! useless test to avoid compilation warnings + END SUBROUTINE iom_update_file_name + +#endif + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname +#if defined key_xios + iom_use = xios_field_is_active( cdname ) +#else + iom_use = .FALSE. +#endif + END FUNCTION iom_use + + SUBROUTINE iom_miss_val( cdname, pmiss_val ) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp) , INTENT(out) :: pmiss_val + REAL(dp) :: ztmp_pmiss_val +#if defined key_xios + ! get missing value + CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) + pmiss_val = ztmp_pmiss_val +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings + IF( .FALSE. ) pmiss_val = 0._wp ! useless assignment to avoid compilation warnings +#endif + END SUBROUTINE iom_miss_val + + !!====================================================================== +END MODULE iom diff --git a/TMP_MY_SRC/istate.F90 b/TMP_MY_SRC/istate.F90 new file mode 100644 index 0000000..d737af7 --- /dev/null +++ b/TMP_MY_SRC/istate.F90 @@ -0,0 +1,192 @@ +MODULE istate + !!====================================================================== + !! *** MODULE istate *** + !! Ocean state : initial state setting + !!===================================================================== + !! History : OPA ! 1989-12 (P. Andrich) Original code + !! 5.0 ! 1991-11 (G. Madec) rewritting + !! 6.0 ! 1996-01 (G. Madec) terrain following coordinates + !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_eel + !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_uvg + !! NEMO 1.0 ! 2003-08 (G. Madec, C. Talandier) F90: Free form, modules + EEL R5 + !! - ! 2004-05 (A. Koch-Larrouy) istate_gyre + !! 2.0 ! 2006-07 (S. Masson) distributed restart using iom + !! 3.3 ! 2010-10 (C. Ethe) merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec) Merge of dtatem and dtasal & suppression of tb,tn/sb,sn + !! 3.7 ! 2016-04 (S. Flavoni) introduce user defined initial state + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! istate_init : initial state setting + !! istate_uvg : initial velocity in geostropic balance + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE daymod ! calendar + USE dtatsd ! data temperature and salinity (dta_tsd routine) + USE dtauvd ! data: U & V current (dta_uvd routine) + USE domvvl ! varying vertical mesh + USE wet_dry ! wetting and drying (needed for wad_istate) + USE usrdef_istate ! User defined initial state + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! MPP library + USE lbclnk ! lateal boundary condition / mpp exchanges + USE restart ! restart + +#if defined key_agrif + USE agrif_oce ! initial state interpolation + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC istate_init ! routine called by nemogcm.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: istate.F90 14991 2021-06-14 19:52:31Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE istate_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields. + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute +!!gm see comment further down + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace +!!gm end + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_init : Initialization of the dynamics and tracers' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + CALL dta_tsd_init ! Initialisation of T & S input data + IF( ln_c1d) CALL dta_uvd_init ! Initialisation of U & V input data (c1d only) + + ts (:,:,:,:,Kaa) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk + IF ( ALLOCATED( rhd ) ) THEN ! SWE, for example, will not have allocated these + rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rn2b (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk + ENDIF +#if defined key_agrif + uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization + vv (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization +#endif + +#if defined key_agrif + IF ( .NOT.Agrif_root() .AND. ln_init_chfrpar ) THEN + numror = 0 ! define numror = 0 -> no restart file to read + ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) + CALL day_init + CALL agrif_istate_oce( Kbb, Kmm, Kaa ) ! Interp from parent + ! + ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) + uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) + vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) + ELSE +#endif + IF( ln_rstart ) THEN ! Restart from a file + ! ! ------------------- + CALL rst_read( Kbb, Kmm ) ! Read the restart file + CALL day_init ! model calendar (using both namelist and restart infos) + ! + IF( ln_reset_ts ) THEN + ! Modifications to overwrite the T &S from the restart files with the + ! initial conditions. + CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data from the specified initial fields. + ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones for T & S. + ENDIF + ELSE ! Start from rest + ! ! --------------- + numror = 0 ! define numror = 0 -> no restart file to read + l_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) + CALL day_init ! model calendar (using both namelist and restart infos) + ! ! Initialization of ocean to zero + ! + IF( ln_tsd_init ) THEN + CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 + ENDIF + ! + IF( ln_uvd_init .AND. ln_c1d ) THEN + CALL dta_uvd( nit000, Kbb, uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) ! read 3D U and V data at nit000 + ELSE + uu (:,:,:,Kbb) = 0._wp ! set the ocean at rest + vv (:,:,:,Kbb) = 0._wp + ENDIF + ! + ! + IF( .NOT. ln_tsd_init .AND. .NOT. ln_uvd_init ) THEN + DO jk = 1, jpk + zgdept(:,:,jk) = gdept(:,:,jk,Kbb) + END DO + CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'istate', ts(:,:,:,jp_tem,Kbb), 'T', 1._wp, ts(:,:,:,jp_sal,Kbb), 'T', 1._wp, & + & uu(:,:,:, Kbb), 'U', -1._wp, vv(:,:,:, Kbb), 'V', -1._wp ) + ENDIF + ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones + uu (:,:,:,Kmm) = uu (:,:,:,Kbb) + vv (:,:,:,Kmm) = vv (:,:,:,Kbb) + ENDIF +#if defined key_agrif + ENDIF +#endif + ! +#if defined key_RK3 + IF( .NOT. ln_rstart ) THEN +#endif + ! Initialize "before" barotropic velocities. "now" values are always set but + ! "before" values may have been read from a restart to ensure restartability. + ! In the non-restart or non-RK3 cases they need to be initialised here: + uu_b(:,:,Kbb) = 0._wp ; vv_b(:,:,Kbb) = 0._wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk) + vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk) + END_3D + uu_b(:,:,Kbb) = uu_b(:,:,Kbb) * r1_hu(:,:,Kbb) + vv_b(:,:,Kbb) = vv_b(:,:,Kbb) * r1_hv(:,:,Kbb) + ! +#if defined key_RK3 + ENDIF +#endif + ! + ! Initialize "now" barotropic velocities: + ! Do it whatever the free surface method, these arrays being used eventually + ! +#if defined key_RK3 + IF( .NOT. ln_rstart ) THEN + uu_b(:,:,Kmm) = uu_b(:,:,Kbb) ! Kmm value set to Kbb for initialisation in Agrif_Regrid in namo_gcm + vv_b(:,:,Kmm) = vv_b(:,:,Kbb) + ENDIF +#else +!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked + uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) + vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + END_3D + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) +#endif + ! + END SUBROUTINE istate_init + + !!====================================================================== +END MODULE istate diff --git a/TMP_MY_SRC/ldftra.F90 b/TMP_MY_SRC/ldftra.F90 new file mode 100644 index 0000000..955b187 --- /dev/null +++ b/TMP_MY_SRC/ldftra.F90 @@ -0,0 +1,976 @@ +MODULE ldftra + !!====================================================================== + !! *** MODULE ldftra *** + !! Ocean physics: lateral diffusivity coefficients + !!===================================================================== + !! History : ! 1997-07 (G. Madec) from inimix.F split in 2 routines + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 2.0 ! 2005-11 (G. Madec) + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) restructuration/simplification of aht/aeiv specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_tra_init : initialization, namelist read, and parameters control + !! ldf_tra : update lateral eddy diffusivity coefficients at each time step + !! ldf_eiv_init : initialization of the eiv coeff. from namelist choices + !! ldf_eiv : time evolution of the eiv coefficients (function of the growth rate of baroclinic instability) + !! ldf_eiv_trp : add to the input ocean transport the contribution of the EIV parametrization + !! ldf_eiv_dia : diagnose the eddy induced velocity from the eiv streamfunction + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfslp ! lateral diffusion: slope of iso-neutral surfaces + USE ldfc1d_c2d ! lateral diffusion: 1D & 2D cases + USE diaptr + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module for ehanced bottom friction file + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_tra_init ! called by nemogcm.F90 + PUBLIC ldf_tra ! called by step.F90 + PUBLIC ldf_eiv_init ! called by nemogcm.F90 + PUBLIC ldf_eiv ! called by step.F90 + PUBLIC ldf_eiv_trp ! called by traadv.F90 + PUBLIC ldf_eiv_dia ! called by traldf_iso and traldf_iso_triad.F90 + + ! !!* Namelist namtra_ldf : lateral mixing on tracers * + ! != Operator type =! + LOGICAL , PUBLIC :: ln_traldf_OFF !: no operator: No explicit diffusion + LOGICAL , PUBLIC :: ln_traldf_lap !: laplacian operator + LOGICAL , PUBLIC :: ln_traldf_blp !: bilaplacian operator + ! != Direction of action =! + LOGICAL , PUBLIC :: ln_traldf_lev !: iso-level direction + LOGICAL , PUBLIC :: ln_traldf_hor !: horizontal (geopotential) direction +! LOGICAL , PUBLIC :: ln_traldf_iso !: iso-neutral direction (see ldfslp) + ! != iso-neutral options =! +! LOGICAL , PUBLIC :: ln_traldf_triad !: griffies triad scheme (see ldfslp) + LOGICAL , PUBLIC :: ln_traldf_msc !: Method of Stabilizing Correction +! LOGICAL , PUBLIC :: ln_triad_iso !: pure horizontal mixing in ML (see ldfslp) +! LOGICAL , PUBLIC :: ln_botmix_triad !: mixing on bottom (see ldfslp) +! REAL(wp), PUBLIC :: rn_sw_triad !: =1/0 switching triad / all 4 triads used (see ldfslp) +! REAL(wp), PUBLIC :: rn_slpmax !: slope limit (see ldfslp) + ! != Coefficients =! + INTEGER , PUBLIC :: nn_aht_ijk_t !: choice of time & space variations of the lateral eddy diffusivity coef. + ! ! time invariant coefficients: aht_0 = 1/2 Ud*Ld (lap case) + ! ! bht_0 = 1/12 Ud*Ld^3 (blp case) + REAL(wp), PUBLIC :: rn_Ud !: lateral diffusive velocity [m/s] + REAL(wp), PUBLIC :: rn_Ld !: lateral diffusive length [m] + + ! !!* Namelist namtra_eiv : eddy induced velocity param. * + ! != Use/diagnose eiv =! + LOGICAL , PUBLIC :: ln_ldfeiv !: eddy induced velocity flag + LOGICAL , PUBLIC :: ln_ldfeiv_dia !: diagnose & output eiv streamfunction and velocity (IOM) + LOGICAL , PUBLIC :: l_ldfeiv_dia !: RK3: modified w.r.t. kstg diagnose & output eiv streamfunction and velocity flag + + ! != Coefficients =! + INTEGER , PUBLIC :: nn_aei_ijk_t !: choice of time/space variation of the eiv coeff. + REAL(wp), PUBLIC :: rn_Ue !: lateral diffusive velocity [m/s] + REAL(wp), PUBLIC :: rn_Le !: lateral diffusive length [m] + INTEGER, PUBLIC :: nn_ldfeiv_shape !: shape of bounding coefficient (Treguier et al formulation only) + + ! ! Flag to control the type of lateral diffusive operator + INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 ! error in specification of lateral diffusion + INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 ! without operator (i.e. no lateral diffusive trend) + ! !! laplacian ! bilaplacian ! + INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 ! iso-level operator + INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 , np_blp_i = 21 ! standard iso-neutral or geopotential operator + INTEGER, PARAMETER, PUBLIC :: np_lap_it = 12 , np_blp_it = 22 ! triad iso-neutral or geopotential operator + + INTEGER , PUBLIC :: nldf_tra = 0 !: type of lateral diffusion used defined from ln_traldf_... (namlist logicals) + LOGICAL , PUBLIC :: l_ldftra_time = .FALSE. !: flag for time variation of the lateral eddy diffusivity coef. + LOGICAL , PUBLIC :: l_ldfeiv_time = .FALSE. !: flag for time variation of the eiv coef. + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtu, ahtv !: eddy diffusivity coef. at U- and V-points [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiu, aeiv !: eddy induced velocity coeff. [m2/s] + + REAL(wp) :: aht0, aei0 ! constant eddy coefficients (deduced from namelist values) [m2/s] + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldftra.F90 15512 2021-11-15 17:22:03Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_tra_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_tra_init *** + !! + !! ** Purpose : initializations of the tracer lateral mixing coeff. + !! + !! ** Method : * the eddy diffusivity coef. specification depends on: + !! + !! ln_traldf_lap = T laplacian operator + !! ln_traldf_blp = T bilaplacian operator + !! + !! nn_aht_ijk_t = 0 => = constant + !! ! + !! = 10 => = F(z) : constant with a reduction of 1/4 with depth + !! ! + !! =-20 => = F(i,j) = shape read in 'eddy_diffusivity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! = 21 = F(i,j,t) = F(growth rate of baroclinic instability) + !! ! + !! =-30 => = F(i,j,k) = shape read in 'eddy_diffusivity_3D.nc' file + !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10) + !! = 31 = F(i,j,k,t) = F(local velocity) ( 1/2 |u|e laplacian operator + !! or 1/12 |u|e^3 bilaplacian operator ) + !! * initialisation of the eddy induced velocity coefficient by a call to ldf_eiv_init + !! + !! ** action : ahtu, ahtv initialized one for all or l_ldftra_time set to true + !! aeiu, aeiv initialized one for all or l_ldfeiv_time set to true + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ioptio, ierr, inum, ios, inn ! local integer + REAL(wp) :: zah_max, zUfac ! - - + CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) + !! + NAMELIST/namtra_ldf/ ln_traldf_OFF, ln_traldf_lap , ln_traldf_blp , & ! type of operator + & ln_traldf_lev, ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator + & ln_traldf_iso, ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator + & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator + & nn_aht_ijk_t , rn_Ud , rn_Ld ! lateral eddy coefficient + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ldf_tra_init : lateral tracer diffusion' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + + ! + ! Choice of lateral tracer physics + ! ================================= + ! + READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) + READ ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) + IF(lwm) WRITE( numond, namtra_ldf ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namtra_ldf --- lateral mixing parameters (type, direction, coefficients)' + WRITE(numout,*) ' type :' + WRITE(numout,*) ' no explicit diffusion ln_traldf_OFF = ', ln_traldf_OFF + WRITE(numout,*) ' laplacian operator ln_traldf_lap = ', ln_traldf_lap + WRITE(numout,*) ' bilaplacian operator ln_traldf_blp = ', ln_traldf_blp + WRITE(numout,*) ' direction of action :' + WRITE(numout,*) ' iso-level ln_traldf_lev = ', ln_traldf_lev + WRITE(numout,*) ' horizontal (geopotential) ln_traldf_hor = ', ln_traldf_hor + WRITE(numout,*) ' iso-neutral Madec operator ln_traldf_iso = ', ln_traldf_iso + WRITE(numout,*) ' iso-neutral triad operator ln_traldf_triad = ', ln_traldf_triad + WRITE(numout,*) ' use the Method of Stab. Correction ln_traldf_msc = ', ln_traldf_msc + WRITE(numout,*) ' maximum isoppycnal slope rn_slpmax = ', rn_slpmax + WRITE(numout,*) ' pure lateral mixing in ML ln_triad_iso = ', ln_triad_iso + WRITE(numout,*) ' switching triad or not rn_sw_triad = ', rn_sw_triad + WRITE(numout,*) ' lateral mixing on bottom ln_botmix_triad = ', ln_botmix_triad + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_aht_ijk_t = ', nn_aht_ijk_t + WRITE(numout,*) ' lateral diffusive velocity (if cst) rn_Ud = ', rn_Ud, ' m/s' + WRITE(numout,*) ' lateral diffusive length (if cst) rn_Ld = ', rn_Ld, ' m' + ENDIF + ! + ! + ! Operator and its acting direction (set nldf_tra) + ! ================================= + ! + nldf_tra = np_ERROR + ioptio = 0 + IF( ln_traldf_OFF ) THEN ; nldf_tra = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF + IF( ln_traldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ln_traldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) + ! + IF( .NOT.ln_traldf_OFF ) THEN !== direction ==>> type of operator ==! + ioptio = 0 + IF( ln_traldf_lev ) ioptio = ioptio + 1 + IF( ln_traldf_hor ) ioptio = ioptio + 1 + IF( ln_traldf_iso ) ioptio = ioptio + 1 + IF( ln_traldf_triad ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE direction (level/hor/iso/triad)' ) + ! + ! ! defined the type of lateral diffusion from ln_traldf_... logicals + ierr = 0 + IF ( ln_traldf_lap ) THEN ! laplacian operator + IF ( ln_zco ) THEN ! z-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed + IF ( ln_traldf_hor ) nldf_tra = np_lap ! horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard (rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad (rotation) + ENDIF + IF ( ln_sco ) THEN ! s-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_lap_i ! horizontal ( rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad ( rotation) + ENDIF + ENDIF + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + IF ( ln_zco ) THEN ! z-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level = horizontal (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_blp ! iso-level = horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed + IF ( ln_traldf_hor ) nldf_tra = np_blp ! horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_sco ) THEN ! s-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_blp_it ! horizontal ( rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + ENDIF + IF ( ierr == 1 ) CALL ctl_stop( 'iso-level in z-partial step, not allowed' ) + ENDIF + ! + IF( ln_isfcav .AND. ln_traldf_triad ) CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) + ! + IF( nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. & + & nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it ) l_ldfslp = .TRUE. ! slope of neutral surfaces required + ! + IF( ln_traldf_blp .AND. ( ln_traldf_iso .OR. ln_traldf_triad) ) THEN ! iso-neutral bilaplacian need MSC + IF( .NOT.ln_traldf_msc ) CALL ctl_stop( 'tra_ldf_init: iso-neutral bilaplacian requires ln_traldf_msc=.true.' ) + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nldf_tra ) + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral diffusion' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> laplacian iso-level operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (standard)' + CASE( np_lap_it ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (triad)' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> bilaplacian iso-level operator' + CASE( np_blp_i ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (standard)' + CASE( np_blp_it ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (triad)' + END SELECT + WRITE(numout,*) + ENDIF + + ! + ! Space/time variation of eddy coefficients + ! =========================================== + ! + l_ldftra_time = .FALSE. ! no time variation except in case defined below + ! + IF( ln_traldf_OFF ) THEN !== no explicit diffusive operator ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> No diffusive operator selected. ahtu and ahtv are not allocated' + RETURN + ! + ELSE !== a lateral diffusion operator is used ==! + ! + ! ! allocate the aht arrays + ALLOCATE( ahtu(jpi,jpj,jpk) , ahtv(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_tra_init: failed to allocate arrays') + ! + ahtu(:,:,jpk) = 0._wp ! last level always 0 + ahtv(:,:,jpk) = 0._wp + !. + ! ! value of lap/blp eddy mixing coef. + IF( ln_traldf_lap ) THEN ; zUfac = r1_2 *rn_Ud ; inn = 1 ; cl_Units = ' m2/s' ! laplacian + ELSEIF( ln_traldf_blp ) THEN ; zUfac = r1_12*rn_Ud ; inn = 3 ; cl_Units = ' m4/s' ! bilaplacian + ENDIF + aht0 = zUfac * rn_Ld**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator for e1=1 degree) + ! + ! + SELECT CASE( nn_aht_ijk_t ) !* Specification of space-time variations of ahtu, ahtv + ! + CASE( 0 ) !== constant ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = constant = ', aht0, cl_Units + ahtu(:,:,1:jpkm1) = aht0 + ahtv(:,:,1:jpkm1) = aht0 + ! + CASE( 10 ) !== fixed profile ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( depth )' + IF(lwp) WRITE(numout,*) ' surface eddy diffusivity = constant = ', aht0, cl_Units + ahtu(:,:,1) = aht0 ! constant surface value + ahtv(:,:,1) = aht0 + CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv ) + ! + CASE ( -20 ) !== fixed horizontal shape and magnitude read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j) read in eddy_diffusivity.nc file' + CALL iom_open( 'eddy_diffusivity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahtu_2D', ahtu(:,:,1), cd_type = 'U', psgn = 1._wp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_2D', ahtv(:,:,1), cd_type = 'V', psgn = 1._wp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + ahtu(:,:,jk) = ahtu(:,:,1) + ahtv(:,:,jk) = ahtv(:,:,1) + END DO + ! + CASE( 20 ) !== fixed horizontal shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap or blp case)' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ud,' m/s and Ld = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , ahtu, ahtv ) ! value proportional to scale factor^inn + ! + CASE( 21 ) !== time varying 2D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, time )' + IF(lwp) WRITE(numout,*) ' = F( growth rate of baroclinic instability )' + IF(lwp) WRITE(numout,*) ' min value = 0.2 * aht0 (with aht0= 1/2 rn_Ud*rn_Ld)' + IF(lwp) WRITE(numout,*) ' max value = aei0 (with aei0=1/2 rn_Ue*Le increased to aht0 within 20N-20S' + ! + l_ldftra_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_tra_init: aht=F( growth rate of baroc. insta .)', & + & ' incompatible with bilaplacian operator' ) + ! + CASE( -30 ) !== fixed 3D shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j,k) read in eddy_diffusivity.nc file' + CALL iom_open( 'eddy_diffusivity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahtu_3D', ahtu, cd_type = 'U', psgn = 1._wp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_3D', ahtv, cd_type = 'V', psgn = 1._wp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !== fixed 3D shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, depth )' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ud,' m/s and Ld = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , ahtu, ahtv ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv ) ! reduction with depth + ! + CASE( 31 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the velocity : 1/2 |u|e or 1/12 |u|e^3' + ! + l_ldftra_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + CASE DEFAULT + CALL ctl_stop('ldf_tra_init: wrong choice for nn_aht_ijk_t, the type of space-time variation of aht') + END SELECT + ! + IF( .NOT.l_ldftra_time ) THEN !* No time variation + IF( ln_traldf_lap ) THEN ! laplacian operator (mask only) + ahtu(:,:,1:jpkm1) = ahtu(:,:,1:jpkm1) * umask(:,:,1:jpkm1) + ahtv(:,:,1:jpkm1) = ahtv(:,:,1:jpkm1) * vmask(:,:,1:jpkm1) + ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator (square root + mask) + ahtu(:,:,1:jpkm1) = SQRT( ahtu(:,:,1:jpkm1) ) * umask(:,:,1:jpkm1) + ahtv(:,:,1:jpkm1) = SQRT( ahtv(:,:,1:jpkm1) ) * vmask(:,:,1:jpkm1) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_tra_init + + + SUBROUTINE ldf_tra( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_tra *** + !! + !! ** Purpose : update at kt the tracer lateral mixing coeff. (aht and aeiv) + !! + !! ** Method : * time varying eddy diffusivity coefficients: + !! + !! nn_aei_ijk_t = 21 aeiu, aeiv = F(i,j, t) = F(growth rate of baroclinic instability) + !! with a reduction to 0 in vicinity of the Equator + !! nn_aht_ijk_t = 21 ahtu, ahtv = F(i,j, t) = F(growth rate of baroclinic instability) + !! + !! = 31 ahtu, ahtv = F(i,j,k,t) = F(local velocity) ( |u|e /12 laplacian operator + !! or |u|e^3/12 bilaplacian operator ) + !! + !! * time varying EIV coefficients: call to ldf_eiv routine + !! + !! ** action : ahtu, ahtv update at each time step + !! aeiu, aeiv - - - - (if ln_ldfeiv=T) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zaht, zahf, zaht_min, zDaht, z1_f20 ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN ! eddy induced velocity coefficients + ! ! =F(growth rate of baroclinic instability) + ! ! max value aeiv_0 ; decreased to 0 within 20N-20S + CALL ldf_eiv( kt, aei0, aeiu, aeiv, Kmm ) + ENDIF + ! + SELECT CASE( nn_aht_ijk_t ) ! Eddy diffusivity coefficients + ! + CASE( 21 ) !== time varying 2D field ==! = F( growth rate of baroclinic instability ) + ! ! min value 0.2*aht0 + ! ! max value aht0 (aei0 if nn_aei_ijk_t=21) + ! ! increase to aht0 within 20N-20S + IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN ! use the already computed aei. + ahtu(:,:,1) = aeiu(:,:,1) + ahtv(:,:,1) = aeiv(:,:,1) + ELSE ! compute aht. + CALL ldf_eiv( kt, aht0, ahtu, ahtv, Kmm ) + ENDIF + ! + z1_f20 = 1._wp / ( 2._wp * omega * SIN( rad * 20._wp ) ) ! 1 / ff(20 degrees) + zaht_min = 0.2_wp * aht0 ! minimum value for aht + zDaht = aht0 - zaht_min + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) + !! ==>>> The Coriolis value is identical for t- & u_points, and for v- and f-points + zaht = ( 1._wp - MIN( 1._wp , ABS( ff_t(ji,jj) * z1_f20 ) ) ) * zDaht + zahf = ( 1._wp - MIN( 1._wp , ABS( ff_f(ji,jj) * z1_f20 ) ) ) * zDaht + ahtu(ji,jj,1) = ( MAX( zaht_min, ahtu(ji,jj,1) ) + zaht ) ! min value zaht_min + ahtv(ji,jj,1) = ( MAX( zaht_min, ahtv(ji,jj,1) ) + zahf ) ! increase within 20S-20N + END_2D + DO jk = 1, jpkm1 ! deeper value = surface value + mask for all levels + ahtu(:,:,jk) = ahtu(:,:,1) * umask(:,:,jk) + ahtv(:,:,jk) = ahtv(:,:,1) * vmask(:,:,jk) + END DO + ! + CASE( 31 ) !== time varying 3D field ==! = F( local velocity ) + IF( ln_traldf_lap ) THEN ! laplacian operator |u| e /12 + DO jk = 1, jpkm1 + ahtu(:,:,jk) = ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_12 ! n.b. uu,vv are masked + ahtv(:,:,jk) = ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_12 + END DO + ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator sqrt( |u| e^3 /12 ) = sqrt( |u| e /12 ) * e + DO jk = 1, jpkm1 + ahtu(:,:,jk) = SQRT( ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_12 ) * e1u(:,:) + ahtv(:,:,jk) = SQRT( ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_12 ) * e2v(:,:) + END DO + ENDIF + ! + END SELECT + ! + CALL iom_put( "ahtu_2d", ahtu(:,:,1) ) ! surface u-eddy diffusivity coeff. + CALL iom_put( "ahtv_2d", ahtv(:,:,1) ) ! surface v-eddy diffusivity coeff. + CALL iom_put( "ahtu_3d", ahtu(:,:,:) ) ! 3D u-eddy diffusivity coeff. + CALL iom_put( "ahtv_3d", ahtv(:,:,:) ) ! 3D v-eddy diffusivity coeff. + ! + IF( ln_ldfeiv ) THEN + CALL iom_put( "aeiu_2d", aeiu(:,:,1) ) ! surface u-EIV coeff. + CALL iom_put( "aeiv_2d", aeiv(:,:,1) ) ! surface v-EIV coeff. + CALL iom_put( "aeiu_3d", aeiu(:,:,:) ) ! 3D u-EIV coeff. + CALL iom_put( "aeiv_3d", aeiv(:,:,:) ) ! 3D v-EIV coeff. + ENDIF + ! + END SUBROUTINE ldf_tra + + + SUBROUTINE ldf_eiv_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_init *** + !! + !! ** Purpose : initialization of the eiv coeff. from namelist choices. + !! + !! ** Method : the eiv diffusivity coef. specification depends on: + !! nn_aei_ijk_t = 0 => = constant + !! ! + !! = 10 => = F(z) : constant with a reduction of 1/4 with depth + !! ! + !! =-20 => = F(i,j) = shape read in 'eddy_induced_velocity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! = 21 = F(i,j,t) = F(growth rate of baroclinic instability) + !! ! + !! =-30 => = F(i,j,k) = shape read in 'eddy_induced_velocity_3D.nc' file + !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10) + !! + !! ** Action : aeiu , aeiv : initialized one for all or l_ldftra_time set to true + !! l_ldfeiv_time : =T if EIV coefficients vary with time + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ierr, inum, ios, inn ! local integer + REAL(wp) :: zah_max, zUfac ! - scalar + !! + NAMELIST/namtra_eiv/ ln_ldfeiv , ln_ldfeiv_dia, & ! eddy induced velocity (eiv) + & nn_aei_ijk_t, rn_Ue, rn_Le, & ! eiv coefficient + & nn_ldfeiv_shape + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ldf_eiv_init : eddy induced velocity parametrization' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) + ! + READ ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_eiv ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist namtra_eiv : ' + WRITE(numout,*) ' Eddy Induced Velocity (eiv) param. ln_ldfeiv = ', ln_ldfeiv + WRITE(numout,*) ' eiv streamfunction & velocity diag. ln_ldfeiv_dia = ', ln_ldfeiv_dia + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_aei_ijk_t = ', nn_aei_ijk_t + WRITE(numout,*) ' lateral diffusive velocity (if cst) rn_Ue = ', rn_Ue, ' m/s' + WRITE(numout,*) ' lateral diffusive length (if cst) rn_Le = ', rn_Le, ' m' + WRITE(numout,*) + ENDIF + ! + l_ldfeiv_time = .FALSE. ! no time variation except in case defined below + ! + ! + IF( .NOT.ln_ldfeiv ) THEN !== Parametrization not used ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity param is NOT used' + ln_ldfeiv_dia = .FALSE. + ! + ELSE !== use the parametrization ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> use eddy induced velocity parametrization' + IF(lwp) WRITE(numout,*) + ! + IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' ) + ! + IF( .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & + & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) + ! != allocate the aei arrays + ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'ldf_eiv: failed to allocate arrays') + ! + ! != Specification of space-time variations of eaiu, aeiv + ! + aeiu(:,:,jpk) = 0._wp ! last level always 0 + aeiv(:,:,jpk) = 0._wp + ! ! value of EIV coef. (laplacian operator) + zUfac = r1_2 *rn_Ue ! velocity factor + inn = 1 ! L-exponent + aei0 = zUfac * rn_Le**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator) + + SELECT CASE( nn_aei_ijk_t ) !* Specification of space-time variations + ! + CASE( 0 ) !-- constant --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = constant = ', aei0, ' m2/s' + aeiu(:,:,1:jpkm1) = aei0 + aeiv(:,:,1:jpkm1) = aei0 + ! + CASE( 10 ) !-- fixed profile --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( depth )' + IF(lwp) WRITE(numout,*) ' surface eddy diffusivity = constant = ', aht0, ' m2/s' + aeiu(:,:,1) = aei0 ! constant surface value + aeiv(:,:,1) = aei0 + CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv ) + ! + CASE ( -20 ) !-- fixed horizontal shape read in file --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j) read in eddy_diffusivity_2D.nc file' + CALL iom_open ( 'eddy_induced_velocity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu(:,:,1), cd_type = 'U', psgn = 1._wp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv(:,:,1), cd_type = 'V', psgn = 1._wp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + aeiu(:,:,jk) = aeiu(:,:,1) + aeiv(:,:,jk) = aeiv(:,:,1) + END DO + ! + CASE( 20 ) !-- fixed horizontal shape --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( e1, e2 )' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ue, ' m/s and Le = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, ' m2/s for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , aeiu, aeiv ) ! value proportional to scale factor^inn + ! + CASE( 21 ) !-- time varying 2D field --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( latitude, longitude, time )' + IF(lwp) WRITE(numout,*) ' = F( growth rate of baroclinic instability )' + IF(lwp) WRITE(numout,*) ' maximum allowed value: aei0 = ', aei0, ' m2/s' + IF(lwp) WRITE(numout,*) ' shape of bounding coefficient : ',nn_ldfeiv_shape + ! + l_ldfeiv_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + CASE( -30 ) !-- fixed 3D shape read in file --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j,k) read in eddy_diffusivity_3D.nc file' + CALL iom_open ( 'eddy_induced_velocity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu, cd_type = 'U', psgn = 1._wp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv, cd_type = 'V', psgn = 1._wp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !-- fixed 3D shape --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( latitude, longitude, depth )' + CALL ldf_c2d( 'TRA', zUfac , inn , aeiu, aeiv ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv ) ! reduction with depth + ! + CASE DEFAULT + CALL ctl_stop('ldf_tra_init: wrong choice for nn_aei_ijk_t, the type of space-time variation of aei') + END SELECT + ! + IF( .NOT.l_ldfeiv_time ) THEN !* mask if No time variation + DO jk = 1, jpkm1 + aeiu(:,:,jk) = aeiu(:,:,jk) * umask(:,:,jk) + aeiv(:,:,jk) = aeiv(:,:,jk) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_eiv_init + + + SUBROUTINE ldf_eiv( kt, paei0, paeiu, paeiv, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv *** + !! + !! ** Purpose : Compute the eddy induced velocity coefficient from the + !! growth rate of baroclinic instability. + !! + !! ** Method : coefficient function of the growth rate of baroclinic instability + !! + !! Reference : Treguier et al. JPO 1997 ; Held and Larichev JAS 1996 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp) , INTENT(in ) :: paei0 ! max value [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: paeiu, paeiv ! eiv coefficient [m2/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zfw, ze3w, zn2, z1_f20, zzaei, z2_3 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zRo, zRo_lim, zTclinic_recip, zaeiw, zratio ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmodslp ! 3D workspace + !!---------------------------------------------------------------------- + ! + zn (:,:) = 0._wp ! Local initialization + zmodslp(:,:,:) = 0._wp + zhw(:,:) = 5._wp + zah(:,:) = 0._wp + zRo(:,:) = 0._wp + zRo_lim(:,:) = 0._wp + zTclinic_recip(:,:) = 0._wp + zratio(:,:) = 0._wp + zaeiw(:,:) = 0._wp + ! ! Compute lateral diffusive coefficient at T-point + IF( ln_traldf_triad ) THEN + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + ! Take the max of N^2 and zero then take the vertical sum + ! of the square root of the resulting N^2 ( required to compute + ! internal Rossby radius Ro = .5 * sum_jpk(N) / f + zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w(ji,jj,jk,Kmm) + ! Compute elements required for the inverse time scale of baroclinic + ! eddies using the isopycnal slopes calculated in ldfslp.F : + ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w)) + ze3w = e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) + zah(ji,jj) = zah(ji,jj) + zn2 * wslp2(ji,jj,jk) * ze3w + zhw(ji,jj) = zhw(ji,jj) + ze3w + END_3D + ELSE + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + ! Take the max of N^2 and zero then take the vertical sum + ! of the square root of the resulting N^2 ( required to compute + ! internal Rossby radius Ro = .5 * sum_jpk(N) / f + zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w(ji,jj,jk,Kmm) + ! Compute elements required for the inverse time scale of baroclinic + ! eddies using the isopycnal slopes calculated in ldfslp.F : + ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w)) + ze3w = e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) + zah(ji,jj) = zah(ji,jj) + zn2 * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & + & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) * ze3w + zhw(ji,jj) = zhw(ji,jj) + ze3w + END_3D + ENDIF + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zfw = MAX( ABS( 2. * omega * SIN( rad * gphit(ji,jj) ) ) , 1.e-10 ) + ! Rossby radius at w-point taken betwenn 2 km and 40km + zRo(ji,jj) = .4 * zn(ji,jj) / zfw + zRo_lim(ji,jj) = MAX( 2.e3 , MIN( zRo(ji,jj), 40.e3 ) ) + ! zRo(ji,jj) = MAX( 2.e3 , MIN( .4 * zn(ji,jj) / zfw, 40.e3 ) ) + ! Compute aeiw by multiplying Ro^2 and T^-1 + zTclinic_recip(ji,jj) = SQRT( MAX(zah(ji,jj),0._wp) / zhw(ji,jj) ) * tmask(ji,jj,1) + zaeiw(ji,jj) = zRo_lim(ji,jj) * zRo_lim(ji,jj) * zTclinic_recip(ji,jj) + ! zaeiw(ji,jj) = zRo(ji,jj) * zRo(ji,jj) * SQRT( MAX(zah(ji,jj),0._wp) / zhw(ji,jj) ) * tmask(ji,jj,1) + END_2D + CALL iom_put('RossRad',zRo) + CALL iom_put('RossRadlim',zRo_lim) + CALL iom_put('Tclinic_recip',zTclinic_recip) + + ! !== Bound on eiv coeff. ==! + z1_f20 = 1._wp / ( 2._wp * omega * sin( rad * 20._wp ) ) + z2_3 = 2._wp/3._wp + + SELECT CASE(nn_ldfeiv_shape) + CASE(0) !! Standard shape applied - decrease in tropics and cap. + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zzaei = MIN( 1._wp, ABS( ff_t(ji,jj) * z1_f20 ) ) * zaeiw(ji,jj) ! tropical decrease + zaeiw(ji,jj) = MIN( zzaei , paei0 ) ! Max value = paei0 + END_2D + + CASE(1) !! Abrupt cut-off on Rossby radius: +! JD : modifications here to introduce scaling by local rossby radius of deformation vs local grid scale +! arbitrary decision that GM is de-activated if local rossy radius larger than 2 times local grid scale +! based on Hallberg (2013) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( zRo(ji,jj) >= ( 2._wp * MIN( e1t(ji,jj), e2t(ji,jj) ) ) ) THEN +! TODO : use a version of zRo that integrates over a few time steps ? + zaeiw(ji,jj) = 0._wp + ELSE + zaeiw(ji,jj) = MIN( zaeiw(ji,jj), paei0 ) + ENDIF + END_2D + + CASE(2) !! Rossby radius ramp type 1: + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zratio(ji,jj) = zRo(ji,jj)/MIN(e1t(ji,jj),e2t(ji,jj)) + zaeiw(ji,jj) = MIN( zaeiw(ji,jj), MAX( 0._wp, MIN( 1._wp, z2_3*(2._wp - zratio(ji,jj)) ) ) * paei0 ) + END_2D + CALL iom_put('RR_GS',zratio) + + CASE(3) !! Rossby radius ramp type 2: + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zratio(ji,jj) = MIN(e1t(ji,jj),e2t(ji,jj))/zRo(ji,jj) + zaeiw(ji,jj) = MIN( zaeiw(ji,jj), MAX( 0._wp, MIN( 1._wp, z2_3*( zratio(ji,jj) - 0.5_wp ) ) ) * paei0 ) + END_2D + + CASE(4) !! bathymetry ramp: + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zaeiw(ji,jj) = MIN( zaeiw(ji,jj), MAX( 0._wp, MIN( 1._wp, 0.001*(ht_0(ji,jj) - 2000._wp) ) ) * paei0 ) + END_2D + + CASE(5) !! Rossby radius ramp type 1 applied to Treguier et al coefficient rather than cap: + !! Note the ramp is RR/GS=[2.0,1.0] (not [2.0,0.5] as for cases 2,3) and we ramp up + !! to 5% of the Treguier et al coefficient, aiming for peak values of around 100m2/s + !! at high latitudes rather than 2000m2/s which is what you get in eORCA025 with an + !! uncapped coefficient. + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zratio(ji,jj) = zRo(ji,jj)/MIN(e1t(ji,jj),e2t(ji,jj)) + zaeiw(ji,jj) = MAX( 0._wp, MIN( 1._wp, 2._wp - zratio(ji,jj) ) ) * 0.05 * zaeiw(ji,jj) + zaeiw(ji,jj) = MIN( zaeiw(ji,jj), paei0 ) + END_2D + CALL iom_put('RR_GS',zratio) + + CASE DEFAULT + CALL ctl_stop('ldf_eiv: Unrecognised option for nn_ldfeiv_shape.') + + END SELECT + + + IF( nn_hls == 1 ) CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition + ! + DO_2D( 0, 0, 0, 0 ) + paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj ) ) * umask(ji,jj,1) + paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) + END_2D + CALL lbc_lnk( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition + + DO jk = 2, jpkm1 !== deeper values equal the surface one ==! + paeiu(:,:,jk) = paeiu(:,:,1) * umask(:,:,jk) + paeiv(:,:,jk) = paeiv(:,:,1) * vmask(:,:,jk) + END DO + ! + END SUBROUTINE ldf_eiv + + + SUBROUTINE ldf_eiv_trp( kt, kit000, pu, pv, pw, cdtype, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_trp *** + !! + !! ** Purpose : add to the input ocean transport the contribution of + !! the eddy induced velocity parametrization. + !! + !! ** Method : The eddy induced transport is computed from a flux stream- + !! function which depends on the slope of iso-neutral surfaces + !! (see ldf_slp). For example, in the i-k plan : + !! psi_uw = mk(aeiu) e2u mi(wslpi) [in m3/s] + !! Utr_eiv = - dk[psi_uw] + !! Vtr_eiv = + di[psi_uw] + !! ln_ldfeiv_dia = T : output the associated streamfunction, + !! velocity and heat transport (call ldf_eiv_dia) + !! + !! ** Action : pu, pv increased by the eiv transport + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars + REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' + ENDIF + ENDIF + + + zpsi_uw(:,:, 1 ) = 0._wp ; zpsi_vw(:,:, 1 ) = 0._wp + zpsi_uw(:,:,jpk) = 0._wp ; zpsi_vw(:,:,jpk) = 0._wp + ! + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 2, jpkm1 ) + zpsi_uw(ji,jj,jk) = - r1_4 * e2u(ji,jj) * ( wslpi(ji,jj,jk ) + wslpi(ji+1,jj,jk) ) & + & * ( aeiu (ji,jj,jk-1) + aeiu (ji ,jj,jk) ) * wumask(ji,jj,jk) + zpsi_vw(ji,jj,jk) = - r1_4 * e1v(ji,jj) * ( wslpj(ji,jj,jk ) + wslpj(ji,jj+1,jk) ) & + & * ( aeiv (ji,jj,jk-1) + aeiv (ji,jj ,jk) ) * wvmask(ji,jj,jk) + END_3D + ! + DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + pu(ji,jj,jk) = pu(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) + pv(ji,jj,jk) = pv(ji,jj,jk) - ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + pw(ji,jj,jk) = pw(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj ,jk) & + & + zpsi_vw(ji,jj,jk) - zpsi_vw(ji ,jj-1,jk) ) + END_3D + ! + ! ! diagnose the eddy induced velocity and associated heat transport +#if defined key_RK3 + IF( l_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) +#else + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) +#endif + ! + END SUBROUTINE ldf_eiv_trp + + + SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_dia *** + !! + !! ** Purpose : diagnose the eddy induced velocity and its associated + !! vertically integrated heat transport. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in) :: psi_uw, psi_vw ! streamfunction [m3/s] + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp ! local scalar + REAL(wp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace + !!---------------------------------------------------------------------- + ! +!!gm I don't like this routine.... Crazy way of doing things, not optimal at all... +!!gm to be redesigned.... + ! !== eiv stream function: output ==! +!!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output +!!gm CALL iom_put( "psi_eiv_vw", psi_vw ) + ! + ! !== eiv velocities: calculate and output ==! + ! + zw3d(:,:,jpk) = 0._wp ! bottom value always 0 + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw] + zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) ) + END_3D + CALL iom_put( "uoce_eiv", zw3d ) + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw] + zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) ) + END_3D + CALL iom_put( "voce_eiv", zw3d ) + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix] + zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) & + & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) + END_3D + CALL iom_put( "woce_eiv", zw3d ) + ! + IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value + DO_2D( 0, 0, 0, 0 ) + zw2d(ji,jj) = rho0 * e1e2t(ji,jj) + END_2D + DO jk = 1, jpk + zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) + END DO + CALL iom_put( "weiv_masstr" , zw3d ) + ENDIF + ! + IF( iom_use('ueiv_masstr') ) THEN + zw3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + zw3d(:,:,jk) = rho0 * ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) + END DO + CALL iom_put( "ueiv_masstr", zw3d ) ! mass transport in i-direction + ENDIF + ! + zztmp = 0.5_wp * rho0 * rcp + IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) & + & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji+1,jj,jk,jp_tem,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction + CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction + ENDIF + ! + IF( iom_use('veiv_masstr') ) THEN + zw3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + zw3d(:,:,jk) = rho0 * ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) + END DO + CALL iom_put( "veiv_masstr", zw3d ) ! mass transport in i-direction + ENDIF + ! + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) & + & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji,jj+1,jk,jp_tem,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction + CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction + ! + IF( iom_use( 'sophteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) + ! + zztmp = 0.5_wp * 0.5 + IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) & + & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji+1,jj,jk,jp_sal,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction + CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction + ENDIF + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) & + & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji,jj+1,jk,jp_sal,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction + CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction + ! + IF( iom_use( 'sopsteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) + ! + ! + END SUBROUTINE ldf_eiv_dia + + !!====================================================================== +END MODULE ldftra diff --git a/cfgs/GLOBAL_QCO/MY_SRC/diawri.F90 b/cfgs/GLOBAL_QCO/MY_SRC/diawri.F90 index a6d3717..9e5af33 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/diawri.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/diawri.F90 @@ -588,7 +588,7 @@ SUBROUTINE dia_wri( kt, Kmm ) INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers INTEGER :: ipka ! ABL INTEGER :: jn, ierror ! local integers - REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars + REAL(dp) :: zsto, zout, zmax, zjulian ! local scalars ! REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace diff --git a/cfgs/GLOBAL_QCO/MY_SRC/domain.F90 b/cfgs/GLOBAL_QCO/MY_SRC/domain.F90 index c4b1bfa..501d2db 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/domain.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/domain.F90 @@ -64,10 +64,11 @@ MODULE domain PUBLIC domain_cfg ! called by nemogcm.F90 !! * Substitutions +# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!------------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: domain.F90 14547 2021-02-25 17:07:15Z techene $ + !! $Id: domain.F90 15270 2021-09-17 14:27:55Z smasson $ !! Software governed by the CeCILL license (see ./LICENSE) !!------------------------------------------------------------------------- CONTAINS @@ -91,6 +92,7 @@ SUBROUTINE dom_init( Kbb, Kmm, Kaa ) ! INTEGER :: ji, jj, jk, jt ! dummy loop indices INTEGER :: iconf = 0 ! local integers + REAL(wp):: zrdt CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 @@ -318,27 +320,8 @@ SUBROUTINE dom_nam ENDIF ! ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 -#if defined key_RK3 - rDt = rn_Dt - r1_Dt = 1._wp / rDt - ! - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) ' ===>>> Runge Kutta 3rd order (RK3) : rDt = ', rDt - WRITE(numout,*) - ENDIF - ! -#else rDt = 2._wp * rn_Dt r1_Dt = 1._wp / rDt - ! - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) ' ===>>> Modified Leap-Frog (MLF) : rDt = ', rDt - WRITE(numout,*) - ENDIF - ! -#endif ! IF( l_SAS .AND. .NOT.ln_linssh ) THEN CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) @@ -423,16 +406,7 @@ SUBROUTINE dom_nam IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist nxioso = nn_wxios ENDIF - ! -#if defined key_RK3 - ! !== RK3: Open the restart file ==! - IF( ln_rstart ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' open the restart file' - CALL rst_read_open - ENDIF -#else - ! !== MLF: Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) + ! !== Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) l_1st_euler = ln_1st_euler ! IF( ln_rstart ) THEN !* Restart case @@ -467,7 +441,6 @@ SUBROUTINE dom_nam IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' l_1st_euler = .TRUE. ENDIF -#endif ! ! !== control of output frequency ==! ! @@ -575,12 +548,12 @@ SUBROUTINE dom_ctl ! llmsk = tmask_i(:,:) == 1._wp ! - CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) - CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) - CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) - CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) - CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) - CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) + CALL mpp_minloc( 'domain', CASTDP(glamt(:,:)), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', CASTDP(gphit(:,:)), llmsk, zgpmin, imip ) + CALL mpp_minloc( 'domain', CASTDP(e1t(:,:)), llmsk, ze1min, imi1 ) + CALL mpp_minloc( 'domain', CASTDP(e2t(:,:)), llmsk, ze2min, imi2 ) + CALL mpp_maxloc( 'domain', CASTDP(glamt(:,:)), llmsk, zglmax, imal ) + CALL mpp_maxloc( 'domain', CASTDP(gphit(:,:)), llmsk, zgpmax, imap ) CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) ! diff --git a/cfgs/GLOBAL_QCO/MY_SRC/domzgr.F90 b/cfgs/GLOBAL_QCO/MY_SRC/domzgr.F90 index defae11..e6036a5 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/domzgr.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/domzgr.F90 @@ -43,10 +43,10 @@ MODULE domzgr PUBLIC dom_zgr ! called by dom_init.F90 !! * Substitutions -# include "vectopt_loop_substitute.h90" +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: domzgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! $Id: domzgr.F90 15556 2021-11-29 15:23:06Z jchanut $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -70,9 +70,13 @@ SUBROUTINE dom_zgr( k_top, k_bot ) !!---------------------------------------------------------------------- INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices ! - INTEGER :: jk ! dummy loop index + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: ikt, ikb ! top/bot index INTEGER :: ioptio, ibat, ios ! local integer + INTEGER :: is_mbkuvf ! ==0 if mbku, mbkv, mbkf to be computed REAL(wp) :: zrefdep ! depth of the reference level (~10m) + REAL(wp), DIMENSION(jpi,jpj ) :: zmsk + REAL(wp), DIMENSION(jpi,jpj,2) :: ztopbot !!---------------------------------------------------------------------- ! IF(lwp) THEN ! Control print @@ -93,15 +97,13 @@ SUBROUTINE dom_zgr( k_top, k_bot ) & gdept_0 , gdepw_0 , & ! gridpoints depth & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors - & k_top , k_bot ) ! 1st & last ocean level + & k_top , k_bot , & ! 1st & last ocean level + & is_mbkuvf, mbku, mbkv, mbkf ) ! U/V/F points bottom levels ! -! DRM 07/08/17 - Modify the top_level (ztop) and bottom_level (zbot) arrays to mask fake ocean points in -! Antarctica. Need to convert the indices to the local values. - k_top( mi0(5), mj0(5):mj0(405) ) = 0 - k_bot( mi0(5), mj0(5):mj0(405) ) = 0 ELSE !== User defined configuration ==! IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' + is_mbkuvf = 0 ! CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth @@ -110,7 +112,36 @@ SUBROUTINE dom_zgr( k_top, k_bot ) & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors & k_top , k_bot ) ! 1st & last ocean level ! + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'dom_zgr', gdept_0, 'T', 1._wp, gdepw_0, 'W', 1._wp, & + & e3u_0, 'U', 1._wp, e3v_0, 'V', 1._wp, e3f_0, 'F', 1._wp, & + & e3w_0, 'W', 1._wp, e3uw_0, 'U', 1._wp, e3vw_0, 'V', 1._wp, & + & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_zgr', e3t_0, 'T', 1._dp, kfillmode = jpfillcopy ) + ztopbot(:,:,1) = REAL(k_top, wp) + ztopbot(:,:,2) = REAL(k_bot, wp) + CALL lbc_lnk( 'dom_zgr', ztopbot, 'T', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + k_top(:,:) = NINT(ztopbot(:,:,1)) + k_bot(:,:) = NINT(ztopbot(:,:,2)) + ! + ENDIF + ! + ! the following is mandatory + ! make sure that closed boundaries are correctly defined in k_top that will be used to compute all mask arrays + ! + zmsk(:,:) = 1._wp ! default: no closed boundaries + IF( .NOT. l_Iperio ) THEN ! E-W closed: + zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0 + zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0 + ENDIF + IF( .NOT. l_Jperio ) THEN ! S closed: + zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0 ENDIF + IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN ! N closed: + zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0 + ENDIF + CALL lbc_lnk( 'usrdef_zgr', zmsk, 'T', 1._wp ) ! set halos + k_top(:,:) = k_top(:,:) * NINT( zmsk(:,:) ) ! !!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears ! Compute gde3w_0 (vertical sum of e3w) @@ -121,7 +152,16 @@ SUBROUTINE dom_zgr( k_top, k_bot ) ! ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled ! in at runtime if ln_closea=.false. - IF( .NOT.ln_closea ) CALL clo_bat( k_top, k_bot ) + IF( ln_closea ) THEN + IF ( ln_maskcs ) THEN + ! mask all the closed sea + CALL clo_msk( k_top, k_bot, mask_opnsea, 'mask_opensea' ) + ELSE IF ( ln_mask_csundef ) THEN + ! defined closed sea are kept + ! mask all the undefined closed sea + CALL clo_msk( k_top, k_bot, mask_csundef, 'mask_csundef' ) + END IF + END IF ! IF(lwp) THEN ! Control print WRITE(numout,*) @@ -140,9 +180,16 @@ SUBROUTINE dom_zgr( k_top, k_bot ) ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) - CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 - - + CALL zgr_top_bot( k_top, k_bot, is_mbkuvf ) ! with a minimum value set to 1 + ! + ! ! ice shelf draft and bathymetry + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikt = mikt(ji,jj) + ikb = mbkt(ji,jj) + bathy (ji,jj) = gdepw_0(ji,jj,ikb+1) + risfdep(ji,jj) = gdepw_0(ji,jj,ikt ) + END_2D + ! ! ! deepest/shallowest W level Above/Below ~10m !!gm BUG in s-coordinate this does not work! zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) @@ -150,7 +197,7 @@ SUBROUTINE dom_zgr( k_top, k_bot ) nla10 = nlb10 - 1 ! deepest W level Above ~10m !!gm end bug ! - IF( nprint == 1 .AND. lwp ) THEN + IF( lwp ) THEN WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & @@ -176,7 +223,8 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve & pdept , pdepw , & ! 3D t & w-points depth & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors & pe3w , pe3uw , pe3vw , & ! - - - - & k_top , k_bot ) ! top & bottom ocean level + & k_top , k_bot , & ! top & bottom ocean level + & k_mbkuvf , k_bot_u , k_bot_v , k_bot_f ) ! U/V/F points bottom levels !!--------------------------------------------------------------------- !! *** ROUTINE zgr_read *** !! @@ -188,14 +236,18 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] - REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3u, pe3v, pe3f! vertical scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t! vertical scale factors [m] REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + INTEGER , INTENT(out) :: k_mbkuvf ! ==1 if mbku, mbkv, mbkf are in file + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_bot_u , k_bot_v, k_bot_f ! bottom levels at U/V/F points ! - INTEGER :: jk ! dummy loop index - INTEGER :: inum ! local logical unit + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: inum, iatt REAL(WP) :: z_zco, z_zps, z_sco, z_cav REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + CHARACTER(len=7) :: catt ! 'zco', 'zps, 'sco' or 'UNKNOWN' !!---------------------------------------------------------------------- ! IF(lwp) THEN @@ -207,28 +259,42 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve CALL iom_open( cn_domcfg, inum ) ! ! !* type of vertical coordinate - CALL iom_get( inum, 'ln_zco' , z_zco ) - CALL iom_get( inum, 'ln_zps' , z_zps ) - CALL iom_get( inum, 'ln_sco' , z_sco ) - IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF - IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF - IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF - ! + CALL iom_getatt( inum, 'VertCoord', catt ) ! returns 'UNKNOWN' if not found + ld_zco = catt == 'zco' ! default = .false. + ld_zps = catt == 'zps' ! default = .false. + ld_sco = catt == 'sco' ! default = .false. ! !* ocean cavities under iceshelves - CALL iom_get( inum, 'ln_isfcav', z_cav ) - IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF + CALL iom_getatt( inum, 'IsfCav', iatt ) ! returns -999 if not found + ld_isfcav = iatt == 1 ! default = .false. + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( catt == 'UNKNOWN' ) THEN + CALL iom_get( inum, 'ln_zco', z_zco ) ; ld_zco = z_zco /= 0._wp + CALL iom_get( inum, 'ln_zps', z_zps ) ; ld_zps = z_zps /= 0._wp + CALL iom_get( inum, 'ln_sco', z_sco ) ; ld_sco = z_sco /= 0._wp + ENDIF + IF( iatt == -999 ) THEN + CALL iom_get( inum, 'ln_isfcav', z_cav ) ; ld_isfcav = z_cav /= 0._wp + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + ! !* ocean top and bottom level + CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF) + k_top(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points + k_bot(:,:) = NINT( z2d(:,:) ) ! ! !* vertical scale factors CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) ! - CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate - CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) ! 3D coordinate + CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) ! ! !* depths ! !- old depth definition (obsolescent feature) @@ -240,12 +306,21 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve & ' depths at t- and w-points read in the domain configuration file') CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) - CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy ) ! ELSE !- depths computed from e3. scale factors CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths +#if defined key_qco && key_isf + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) ! vertical sum at partial cell xxxx other level + IF( jk == k_top(ji,jj) ) THEN ! first ocean point : partial cell + pdept(ji,jj,jk) = pdepw(ji,jj,jk ) + 0.5_wp * pe3w(ji,jj,jk) ! = risfdep + 1/2 e3w_0(mikt) + ELSE ! other levels + pdept(ji,jj,jk) = pdept(ji,jj,jk-1) + pe3w(ji,jj,jk) + ENDIF + END_3D +#endif IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' @@ -254,11 +329,18 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve ENDIF ENDIF ! - ! !* ocean top and bottom level - CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) - k_top(:,:) = NINT( z2d(:,:) ) - CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points - k_bot(:,:) = NINT( z2d(:,:) ) + IF( iom_varid( inum, 'mbku', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv & mbkf read in ', TRIM(cn_domcfg), ' file' + CALL iom_get( inum, jpdom_global, 'mbku', z2d, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_u(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkv', z2d, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_v(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkf', z2d, cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_f(:,:) = NINT( z2d(:,:) ) + k_mbkuvf = 1 + ELSE + k_mbkuvf = 0 + ENDIF ! ! reference depth for negative bathy (wetting and drying only) IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) @@ -268,7 +350,7 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve END SUBROUTINE zgr_read - SUBROUTINE zgr_top_bot( k_top, k_bot ) + SUBROUTINE zgr_top_bot( k_top, k_bot, k_mbkuvf ) !!---------------------------------------------------------------------- !! *** ROUTINE zgr_top_bot *** !! @@ -280,10 +362,11 @@ SUBROUTINE zgr_top_bot( k_top, k_bot ) !! ocean level at t-, u- & v-points !! (min value = 1) !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest - !! ocean level at t-, u- & v-points + !! mbkf ocean level at t-, u-, v- & f-points !! (min value = 1 over land) !!---------------------------------------------------------------------- INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices + INTEGER , INTENT(in) :: k_mbkuvf ! flag to recompute mbku, mbkv, mbkf ! INTEGER :: ji, jj ! dummy loop indices REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace @@ -299,23 +382,65 @@ SUBROUTINE zgr_top_bot( k_top, k_bot ) ! ! N.B. top k-index of W-level = mikt ! ! bottom k-index of W-level = mbkt+1 - DO jj = 1, jpjm1 - DO ji = 1, jpim1 - miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) - mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) - mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) - ! + DO_2D( 0, 0, 0, 0 ) + miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) + mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) + mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) + END_2D + + IF ( k_mbkuvf==0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf computed from mbkt' + DO_2D( 0, 0, 0, 0 ) mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) - END DO - END DO - ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk - zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + mbkf(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ELSE + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf read from file' + ! Use mbku, mbkv, mbkf from file + ! Ensure these are lower than expected bottom level deduced from mbkt + DO_2D( 0, 0, 0, 0 ) + mbku(ji,jj) = MIN( mbku(ji,jj), mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkv(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj) ) + mbkf(ji,jj) = MIN( mbkf(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ENDIF + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( miku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! - zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mbkf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! END SUBROUTINE zgr_top_bot diff --git a/cfgs/GLOBAL_QCO/MY_SRC/dtatsd.F90 b/cfgs/GLOBAL_QCO/MY_SRC/dtatsd.F90 index 31d623d..4dbab26 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/dtatsd.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/dtatsd.F90 @@ -135,13 +135,13 @@ SUBROUTINE dta_tsd( kt, ptsd ) !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step - REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data + REAL(dp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data ! INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n - REAL(wp):: zl, zi ! local scalars - REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace + REAL(dp):: zl, zi ! local scalars + REAL(dp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain diff --git a/cfgs/GLOBAL_QCO/MY_SRC/iom.F90 b/cfgs/GLOBAL_QCO/MY_SRC/iom.F90 index 8a1b561..3d52216 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/iom.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/iom.F90 @@ -55,7 +55,6 @@ MODULE iom #else LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag #endif - LOGICAL, PUBLIC :: l_iom = .TRUE. !: RK3 iom flag prevent writing at stage 1&2 PUBLIC iom_init, iom_init_closedef, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_get_var PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val @@ -99,7 +98,7 @@ MODULE iom # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: iom.F90 15512 2021-11-15 17:22:03Z techene $ + !! $Id: iom.F90 15033 2021-06-21 10:24:45Z smasson $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -264,7 +263,9 @@ SUBROUTINE iom_init( cdname, kdid, ld_closedef ) # if defined key_si3 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) ! SIMIP diagnostics (4 main arctic straits) - CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) +! remove from si3 case to general case to use dct diagnostics over +! oce+ice +! CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) # endif #if defined key_top IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) @@ -277,6 +278,12 @@ SUBROUTINE iom_init( cdname, kdid, ld_closedef ) INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) nbasin = 1 + 4 * COUNT( (/ll_exist/) ) CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) + ! Transport diagnostics diadct - max number of section 150 in diadct -> ! pb to ensure consistency here + IF( ln_diadct ) THEN + CALL iom_set_axis_attr( "nstrait" , (/ (REAL(ji,wp), ji=1,nb_sec) /) ) + ELSE + CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) + ENDIF ENDIF ! ! automatic definitions of some of the xml attributs @@ -1045,19 +1052,13 @@ SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) INTEGER , INTENT(in ) :: kdom ! Type of domain to be read CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field - REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ALLOCATE(ztmp_pvar(size(pvar,1))) - CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & - & ktime=ktime, kstart=kstart, kcount=kcount ) - pvar = ztmp_pvar - DEALLOCATE(ztmp_pvar) - END IF + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvsp1d = pvar, & + & ktime = ktime, kstart = kstart, kcount = kcount ) ENDIF END SUBROUTINE iom_g1d_sp @@ -1072,8 +1073,8 @@ SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & - & ktime=ktime, kstart=kstart, kcount=kcount) + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvdp1d = pvar, & + & ktime = ktime, kstart = kstart, kcount = kcount) ENDIF END SUBROUTINE iom_g1d_dp @@ -1082,23 +1083,17 @@ SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, k INTEGER , INTENT(in ) :: kdom ! Type of domain to be read CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field - REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) - REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold + REAL(sp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) - CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & - & cd_type = cd_type, psgn = psgn , kfill = kfill, & - & kstart = kstart , kcount = kcount ) - pvar = ztmp_pvar - DEALLOCATE(ztmp_pvar) - ENDIF + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvsp2d = pvar, & + & cd_type = cd_type, psgn_sp = psgn, kfill = kfill, & + & ktime = ktime, kstart = kstart, kcount = kcount ) ENDIF END SUBROUTINE iom_g2d_sp @@ -1115,9 +1110,9 @@ SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, k INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & - & cd_type = cd_type, psgn = psgn , kfill = kfill, & - & kstart = kstart , kcount = kcount ) + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvdp2d = pvar, & + & cd_type = cd_type, psgn_dp = psgn, kfill = kfill, & + & ktime = ktime, kstart = kstart, kcount = kcount ) ENDIF END SUBROUTINE iom_g2d_dp @@ -1126,23 +1121,17 @@ SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, k INTEGER , INTENT(in ) :: kdom ! Type of domain to be read CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field - REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) - REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + REAL(sp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) - CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & - & cd_type = cd_type, psgn = psgn , kfill = kfill, & - & kstart = kstart , kcount = kcount ) - pvar = ztmp_pvar - DEALLOCATE(ztmp_pvar) - END IF + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvsp3d = pvar, & + & cd_type = cd_type, psgn_sp = psgn, kfill = kfill, & + & ktime = ktime, kstart = kstart, kcount = kcount ) ENDIF END SUBROUTINE iom_g3d_sp @@ -1159,18 +1148,16 @@ SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, k INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis ! IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & - & cd_type = cd_type, psgn = psgn , kfill = kfill, & - & kstart = kstart , kcount = kcount ) - END IF + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar, pvdp3d = pvar, & + & cd_type = cd_type, psgn_dp = psgn, kfill = kfill, & + & ktime = ktime, kstart = kstart, kcount = kcount ) ENDIF END SUBROUTINE iom_g3d_dp !!---------------------------------------------------------------------- - SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & - & cd_type, psgn, kfill, kstart, kcount ) + SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pvsp1d, pvsp2d, pvsp3d, pvdp1d, pvdp2d, pvdp3d, & + & ktime , cd_type, psgn_sp, psgn_dp, kfill, kstart, kcount ) !!----------------------------------------------------------------------- !! *** ROUTINE iom_get_123d *** !! @@ -1181,12 +1168,16 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , INTEGER , INTENT(in ) :: kiomid ! Identifier of the file INTEGER , INTENT(in ) :: kdom ! Type of domain to be read CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable - REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) - REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) - REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + REAL(sp), DIMENSION(:) , INTENT( out), OPTIONAL :: pvsp1d ! read field (1D case), single precision + REAL(sp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pvsp2d ! read field (2D case), single precision + REAL(sp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pvsp3d ! read field (3D case), single precision + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pvdp1d ! read field (1D case), double precision + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pvdp2d ! read field (2D case), double precision + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pvdp3d ! read field (3D case), double precision INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) - REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + REAL(sp) , INTENT(in ), OPTIONAL :: psgn_sp ! -1.(1.) : (not) change sign across the north fold + REAL(dp) , INTENT(in ), OPTIONAL :: psgn_dp ! -1.(1.) : (not) change sign across the north fold INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis @@ -1207,22 +1198,36 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , INTEGER, DIMENSION(jpmax_dims) :: icnt ! number of value to read along each axis INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable - REAL(dp) :: zscf, zofs ! sacle_factor and add_offset - REAL(wp) :: zsgn ! local value of psgn + REAL(sp) :: zscf_sp, zofs_sp ! sacle_factor and add_offset, single precision + REAL(dp) :: zscf_dp, zofs_dp ! sacle_factor and add_offset, double precision + REAL(sp) :: zsgn_sp ! local value of psgn, single precision + REAL(dp) :: zsgn_dp ! local value of psgn, double precision INTEGER :: itmp ! temporary integer CHARACTER(LEN=256) :: clinfo ! info character CHARACTER(LEN=256) :: clname ! file name CHARACTER(LEN=1) :: clrankpv, cldmspc ! CHARACTER(LEN=1) :: cl_type ! local value of cd_type LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. + LOGICAL :: llis1d, llis2d, llis3d + LOGICAL :: llsp ! use single precision INTEGER :: inlev ! number of levels for 3D data - REAL(dp) :: gma, gmi !--------------------------------------------------------------------- CHARACTER(LEN=lc) :: context ! CALL set_xios_context(kiomid, context) + ! + llsp = PRESENT(pvsp1d) .OR. PRESENT(pvsp2d) .OR. PRESENT(pvsp3d) + IF( llsp ) THEN + llis1d = PRESENT(pvsp1d) ; IF( llis1d ) ishape(1:1) = SHAPE(pvsp1d) + llis2d = PRESENT(pvsp2d) ; IF( llis2d ) ishape(1:2) = SHAPE(pvsp2d) + llis3d = PRESENT(pvsp3d) ; IF( llis3d ) ishape(1:3) = SHAPE(pvsp3d) + ELSE + llis1d = PRESENT(pvdp1d) ; IF( llis1d ) ishape(1:1) = SHAPE(pvdp1d) + llis2d = PRESENT(pvdp2d) ; IF( llis2d ) ishape(1:2) = SHAPE(pvdp2d) + llis3d = PRESENT(pvdp3d) ; IF( llis3d ) ishape(1:3) = SHAPE(pvdp3d) + ENDIF inlev = -1 - IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) + IF( llis3d ) inlev = ishape(3) ! idom = kdom istop = nstop @@ -1264,27 +1269,27 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , itime = 1 IF( PRESENT(ktime) ) itime = ktime ! - irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) ) + irankpv = 1 * COUNT( (/ llis1d /) ) + 2 * COUNT( (/ llis2d /) ) + 3 * COUNT( (/ llis3d /) ) WRITE(clrankpv, fmt='(i1)') irankpv WRITE(cldmspc , fmt='(i1)') idmspc ! IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... - IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: + IF( llis3d .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: llok = inlev == 1 ! -> 3rd dimension must be equal to 1 - ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: - llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 - ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: - llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 + ELSEIF( llis3d .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: + llok = inlev == 1 .AND. ishape(2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 + ELSEIF( llis3d .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: + llok = ishape(2) == 1 ! -> 2nd dimension must be equal to 1 ELSE llok = .FALSE. ENDIF IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & & '=> cannot read a true '//clrankpv//'D array from this file...' ) ELSEIF( idmspc == irankpv ) THEN - IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & + IF( llis1d .AND. idom /= jpdom_unknown ) & & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... - IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN + IF( llis2d .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN CALL ctl_warn( TRIM(clinfo), '2D array input but 3 spatial dimensions in the file...' , & & 'As the size of the z dimension is 1 and as we try to read the first record, ', & & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) @@ -1310,11 +1315,11 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , ELSE icnt (1:idmspc) = idimsz(1:idmspc) ENDIF - ELSE ! not a 1D array as pv_r1d requires jpdom_unknown + ELSE ! not a 1D array as pv(sd)p1d requires jpdom_unknown ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) icnt(1:2) = (/ Ni_0, Nj_0 /) - IF( PRESENT(pv_r3d) ) THEN + IF( llis3d ) THEN IF( idom == jpdom_auto_xy ) THEN istart(3) = kstart(3) icnt (3) = kcount(3) @@ -1338,21 +1343,28 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , ! check that icnt matches the input array !- IF( idom == jpdom_unknown ) THEN - IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d) - IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d) - IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d) ctmp1 = 'd' - ELSE - IF( irankpv == 2 ) THEN - ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' + ELSE ! we must redefine ishape as we don't read the full array + IF( llis2d ) THEN + IF( llsp ) THEN ; ishape(1:2) = SHAPE(pvsp2d(Nis0:Nie0,Njs0:Nje0 )) + ELSE ; ishape(1:2) = SHAPE(pvdp2d(Nis0:Nie0,Njs0:Nje0 )) + ENDIF + ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' ENDIF - IF( irankpv == 3 ) THEN - ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' + IF( llis3d ) THEN + IF( llsp ) THEN ; ishape(1:3) = SHAPE(pvsp3d(Nis0:Nie0,Njs0:Nje0,:)) + ELSE ; ishape(1:3) = SHAPE(pvdp3d(Nis0:Nie0,Njs0:Nje0,:)) + ENDIF + ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' ENDIF ENDIF DO jl = 1, irankpv WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) - IF( ishape(jl) /= icnt(jl) ) CALL ctl_stop( TRIM(clinfo), 'size(pv_r'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) ) + IF( llsp ) THEN + IF( ishape(jl) /= icnt(jl) ) CALL ctl_stop( TRIM(clinfo), 'size(pvsp'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) ) + ELSE + IF( ishape(jl) /= icnt(jl) ) CALL ctl_stop( TRIM(clinfo), 'size(pvdp'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) ) + ENDIF END DO ENDIF @@ -1366,21 +1378,32 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) ENDIF - CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) + CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, & + & pvsp1d, pvsp2d, pvsp3d, pvdp1d, pvdp2d, pvdp3d ) IF( istop == nstop ) THEN ! no additional errors until this point... IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) cl_type = 'T' IF( PRESENT(cd_type) ) cl_type = cd_type - zsgn = 1._wp - IF( PRESENT(psgn ) ) zsgn = psgn - !--- overlap areas and extra hallows (mpp) - IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN - CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) - ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN - CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) + IF( llsp ) THEN + zsgn_sp = 1._sp + IF( PRESENT(psgn_sp) ) zsgn_sp = psgn_sp + IF( llis2d .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pvsp2d, cl_type, zsgn_sp, kfillmode = kfill ) + ELSEIF( llis3d .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pvsp3d, cl_type, zsgn_sp, kfillmode = kfill ) + ENDIF + ELSE + zsgn_dp = 1._dp + IF( PRESENT(psgn_dp) ) zsgn_dp = psgn_dp + IF( llis2d .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pvdp2d, cl_type, zsgn_dp, kfillmode = kfill ) + ELSEIF( llis3d .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pvdp3d, cl_type, zsgn_dp, kfillmode = kfill ) + ENDIF ENDIF + !--- overlap areas and extra hallows (mpp) ! ELSE ! return if istop == nstop is false @@ -1396,26 +1419,39 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , !would be good to be able to check which context is active and swap only if current is not restart idvar = iom_varid( kiomid, cdvar ) CALL iom_swap(context) - zsgn = 1._wp - IF( PRESENT(psgn ) ) zsgn = psgn + IF( llsp ) THEN + zsgn_sp = 1._sp ; IF( PRESENT(psgn_sp) ) zsgn_sp = psgn_sp + ELSE + zsgn_dp = 1._dp ; IF( PRESENT(psgn_dp) ) zsgn_dp = psgn_dp + ENDIF cl_type = 'T' IF( PRESENT(cd_type) ) cl_type = cd_type - IF( PRESENT(pv_r3d) ) THEN + IF( llis3d ) THEN IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) - CALL xios_recv_field( TRIM(cdvar), pv_r3d(:, :, :)) + IF( llsp ) THEN ; CALL xios_recv_field( TRIM(cdvar), pvsp3d ) + ELSE ; CALL xios_recv_field( TRIM(cdvar), pvdp3d ) + ENDIF IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN - CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) + IF( llsp ) THEN ; CALL lbc_lnk( 'iom', pvsp3d, cl_type, zsgn_sp, kfillmode = kfill) + ELSE ; CALL lbc_lnk( 'iom', pvdp3d, cl_type, zsgn_dp, kfillmode = kfill) + ENDIF ENDIF - ELSEIF( PRESENT(pv_r2d) ) THEN + ELSEIF( llis2d ) THEN IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) - CALL xios_recv_field( TRIM(cdvar), pv_r2d(:, :)) + IF( llsp ) THEN ; CALL xios_recv_field( TRIM(cdvar), pvsp2d ) + ELSE ; CALL xios_recv_field( TRIM(cdvar), pvdp2d ) + ENDIF IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN - CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) + IF( llsp ) THEN ; CALL lbc_lnk('iom', pvsp2d, cl_type, zsgn_sp, kfillmode = kfill) + ELSE ; CALL lbc_lnk('iom', pvdp2d, cl_type, zsgn_dp, kfillmode = kfill) + ENDIF ENDIF - ELSEIF( PRESENT(pv_r1d) ) THEN + ELSEIF( llis1d ) THEN IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) - CALL xios_recv_field( TRIM(cdvar), pv_r1d) + IF( llsp ) THEN ; CALL xios_recv_field( TRIM(cdvar), pvsp1d ) + ELSE ; CALL xios_recv_field( TRIM(cdvar), pvdp1d ) + ENDIF ENDIF CALL iom_swap(cxios_context) #else @@ -1425,17 +1461,32 @@ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , ENDIF !--- Apply scale_factor and offset - zscf = iom_file(kiomid)%scf(idvar) ! scale factor - zofs = iom_file(kiomid)%ofs(idvar) ! offset - IF( PRESENT(pv_r1d) ) THEN - IF( zscf /= 1._wp ) pv_r1d(:) = pv_r1d(:) * zscf - IF( zofs /= 0._wp ) pv_r1d(:) = pv_r1d(:) + zofs - ELSEIF( PRESENT(pv_r2d) ) THEN - IF( zscf /= 1._wp) pv_r2d(:,:) = pv_r2d(:,:) * zscf - IF( zofs /= 0._wp) pv_r2d(:,:) = pv_r2d(:,:) + zofs - ELSEIF( PRESENT(pv_r3d) ) THEN - IF( zscf /= 1._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf - IF( zofs /= 0._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs + IF( llsp ) THEN + zscf_sp = iom_file(kiomid)%scf(idvar) ! scale factor + zofs_sp = iom_file(kiomid)%ofs(idvar) ! offset + IF( llis1d ) THEN + IF( zscf_sp /= 1._sp ) pvsp1d(: ) = pvsp1d(: ) * zscf_sp + IF( zofs_sp /= 0._sp ) pvsp1d(: ) = pvsp1d(: ) + zofs_sp + ELSEIF( llis2d ) THEN + IF( zscf_sp /= 1._sp ) pvsp2d(:,: ) = pvsp2d(:,: ) * zscf_sp + IF( zofs_sp /= 0._sp ) pvsp2d(:,: ) = pvsp2d(:,: ) + zofs_sp + ELSEIF( llis3d ) THEN + IF( zscf_sp /= 1._sp ) pvsp3d(:,:,:) = pvsp3d(:,:,:) * zscf_sp + IF( zofs_sp /= 0._sp ) pvsp3d(:,:,:) = pvsp3d(:,:,:) + zofs_sp + ENDIF + ELSE + zscf_dp = iom_file(kiomid)%scf(idvar) ! scale factor + zofs_dp = iom_file(kiomid)%ofs(idvar) ! offset + IF( llis1d ) THEN + IF( zscf_dp /= 1._dp ) pvdp1d(: ) = pvdp1d(: ) * zscf_dp + IF( zofs_dp /= 0._dp ) pvdp1d(: ) = pvdp1d(: ) + zofs_dp + ELSEIF( llis2d ) THEN + IF( zscf_dp /= 1._dp ) pvdp2d(:,: ) = pvdp2d(:,: ) * zscf_dp + IF( zofs_dp /= 0._dp ) pvdp2d(:,: ) = pvdp2d(:,: ) + zofs_dp + ELSEIF( llis3d ) THEN + IF( zscf_dp /= 1._dp ) pvdp3d(:,:,:) = pvdp3d(:,:,:) * zscf_dp + IF( zofs_dp /= 0._dp ) pvdp3d(:,:,:) = pvdp3d(:,:,:) + zofs_dp + ENDIF ENDIF ! END SUBROUTINE iom_get_123d @@ -1621,32 +1672,8 @@ SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rs0 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvsp0d = pvar ) + ! END SUBROUTINE iom_rp0d_sp SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) @@ -1661,32 +1688,8 @@ SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rd0 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvdp0d = pvar ) + ! END SUBROUTINE iom_rp0d_dp @@ -1702,32 +1705,8 @@ SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rs1 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvsp1d = pvar ) + ! END SUBROUTINE iom_rp1d_sp SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) @@ -1742,35 +1721,11 @@ SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rd1 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvdp1d = pvar ) + ! END SUBROUTINE iom_rp1d_dp - + SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER , INTENT(in) :: kt ! ocean time-step INTEGER , INTENT(in) :: kwrite ! writing time-step @@ -1783,32 +1738,8 @@ SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rs2 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvsp2d = pvar ) + ! END SUBROUTINE iom_rp2d_sp SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) @@ -1823,32 +1754,8 @@ SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rd2 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvdp2d = pvar ) + ! END SUBROUTINE iom_rp2d_dp @@ -1864,32 +1771,8 @@ SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! - CALL set_xios_context(kiomid, context) - - llx = .NOT. (context == "NONE") - - IF( llx ) THEN -#ifdef key_xios - IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) - CALL iom_swap(cxios_context) - ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',TRIM(cdvar) - CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rs3 = pvar ) - CALL iom_swap(cxios_context) - ENDIF -#endif - ELSE - IF( kiomid > 0 ) THEN - IF( iom_file(kiomid)%nfid > 0 ) THEN - ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) - ENDIF - ENDIF - ENDIF + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvsp3d = pvar ) + ! END SUBROUTINE iom_rp3d_sp SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) @@ -1904,6 +1787,29 @@ SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) INTEGER :: ivid ! variable id CHARACTER(LEN=lc) :: context ! + CALL iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvdp3d = pvar ) + ! + END SUBROUTINE iom_rp3d_dp + + SUBROUTINE iom_rp0123d( kt, kwrite, kiomid, cdvar, ktype, pvsp0d, pvsp1d, pvsp2d, pvsp3d, pvdp0d, pvdp1d, pvdp2d, pvdp3d ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + REAL(sp) , INTENT(in), OPTIONAL :: pvsp0d ! read field (0D case), single precision + REAL(sp), DIMENSION(:) , INTENT(in), OPTIONAL :: pvsp1d ! read field (1D case), single precision + REAL(sp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: pvsp2d ! read field (2D case), single precision + REAL(sp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: pvsp3d ! read field (3D case), single precision + REAL(dp) , INTENT(in), OPTIONAL :: pvdp0d ! read field (0D case), double precision + REAL(dp), DIMENSION(:) , INTENT(in), OPTIONAL :: pvdp1d ! read field (1D case), double precision + REAL(dp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: pvdp2d ! read field (2D case), double precision + REAL(dp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: pvdp3d ! read field (3D case), double precision + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! CALL set_xios_context(kiomid, context) llx = .NOT. (context == "NONE") @@ -1911,14 +1817,22 @@ SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) IF( llx ) THEN #ifdef key_xios IF( kt == kwrite ) THEN - IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',TRIM(cdvar) + IF(lwp) write(numout,*) 'RESTART: write (XIOS) ',TRIM(cdvar) CALL iom_swap(context) - CALL iom_put(TRIM(cdvar), pvar) + IF( PRESENT(pvsp0d) ) CALL iom_put(TRIM(cdvar), pvsp0d) + IF( PRESENT(pvsp1d) ) CALL iom_put(TRIM(cdvar), pvsp1d) + IF( PRESENT(pvsp2d) ) CALL iom_put(TRIM(cdvar), pvsp2d) + IF( PRESENT(pvsp3d) ) CALL iom_put(TRIM(cdvar), pvsp3d) + IF( PRESENT(pvdp0d) ) CALL iom_put(TRIM(cdvar), pvdp0d) + IF( PRESENT(pvdp1d) ) CALL iom_put(TRIM(cdvar), pvdp1d) + IF( PRESENT(pvdp2d) ) CALL iom_put(TRIM(cdvar), pvdp2d) + IF( PRESENT(pvdp3d) ) CALL iom_put(TRIM(cdvar), pvdp3d) CALL iom_swap(cxios_context) ELSE - IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',TRIM(cdvar) + IF(lwp) write(numout,*) 'RESTART: define (XIOS)',TRIM(cdvar) CALL iom_swap(context) - CALL iom_set_rstw_active( TRIM(cdvar), rd3 = pvar ) + CALL iom_set_rstw_active( TRIM(cdvar), rs0 = pvsp0d, rs1 = pvsp1d, rs2 = pvsp2d, rs3 = pvsp3d & + & , rd0 = pvdp0d, rd1 = pvdp1d, rd2 = pvdp2d, rd3 = pvdp3d ) CALL iom_swap(cxios_context) ENDIF #endif @@ -1926,12 +1840,12 @@ SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) IF( kiomid > 0 ) THEN IF( iom_file(kiomid)%nfid > 0 ) THEN ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) - CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pvsp0d, pvsp1d, pvsp2d, pvsp3d, & + & pvdp0d, pvdp1d, pvdp2d, pvdp3d ) ENDIF ENDIF ENDIF - END SUBROUTINE iom_rp3d_dp - + END SUBROUTINE iom_rp0123d SUBROUTINE iom_delay_rst( cdaction, cdcpnt, kncid ) @@ -2036,7 +1950,9 @@ SUBROUTINE iom_p2d_sp( cdname, pfield2d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield2d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield2d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield2d ) ENDIF @@ -2052,7 +1968,9 @@ SUBROUTINE iom_p2d_dp( cdname, pfield2d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield2d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield2d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield2d ) ENDIF @@ -2068,7 +1986,9 @@ SUBROUTINE iom_p3d_sp( cdname, pfield3d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield3d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield3d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield3d ) ENDIF @@ -2084,7 +2004,9 @@ SUBROUTINE iom_p3d_dp( cdname, pfield3d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield3d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield3d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield3d ) ENDIF @@ -2100,7 +2022,9 @@ SUBROUTINE iom_p4d_sp( cdname, pfield4d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield4d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield4d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield4d ) ENDIF @@ -2116,7 +2040,9 @@ SUBROUTINE iom_p4d_dp( cdname, pfield4d ) IF( iom_use(cdname) ) THEN #if defined key_xios IF( is_tile(pfield4d) == 1 ) THEN +#if ! defined key_xios3 CALL xios_send_field( cdname, pfield4d, ntile - 1 ) +#endif ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN CALL xios_send_field( cdname, pfield4d ) ENDIF @@ -2152,18 +2078,22 @@ SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, IF( xios_is_valid_domain (cdid) ) THEN CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & +#if ! defined key_xios3 & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & +#endif & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') ENDIF IF( xios_is_valid_domaingroup(cdid) ) THEN CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & +#if ! defined key_xios3 & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & +#endif & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) ENDIF @@ -2344,9 +2274,11 @@ SUBROUTINE set_grid( cdgrd, plon, plat, ldxios, ldrxios ) LOGICAL, INTENT(IN) :: ldxios, ldrxios !!---------------------------------------------------------------------- ! + ! nn_hls halo points CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni=jpi, data_jbegin = -nn_hls, data_nj=jpj) + ! Inner domain only CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ni_glo = Ni0glo, nj_glo = Nj0glo, & & ibegin = mig0(Nis0) - 1, jbegin = mjg0(Njs0) - 1, ni = Ni_0, nj = Nj_0) CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", data_dim=2, data_ibegin = 0, data_ni=Ni_0, data_jbegin = 0, data_nj=Nj_0) @@ -2358,14 +2290,16 @@ SUBROUTINE set_grid( cdgrd, plon, plat, ldxios, ldrxios ) idb(jn) = -nn_hls ! Tile data offset (halo size) END DO - ! Tile_[ij]begin are defined with respect to the processor data domain, so data_[ij]begin is added + ! Data includes all halo points CALL iom_set_domain_attr("grid_"//cdgrd, ntiles=nijtile, & - & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, & & tile_ni=ini(:), tile_nj=inj(:), & & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) + ! Data contains no halo points + idb(:) = 0 CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ntiles=nijtile, & - & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, & & tile_ni=ini(:), tile_nj=inj(:), & & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) @@ -2534,6 +2468,9 @@ SUBROUTINE set_xmlatt f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ABL' , freq_op=f_op, freq_offset=f_of) + IF( ln_diadct ) THEN + f_op%timestep = nn_dctwri ; f_of%timestep = 0 ; CALL iom_set_field_attr('DCT' , freq_op=f_op, freq_offset=f_of) + ENDIF ! output file names (attribut: name) DO ji = 1, 9 @@ -2662,7 +2599,7 @@ SUBROUTINE iom_update_file_name( cdid ) INTEGER :: jn, iln INTEGER :: itrlen INTEGER :: iyear, imonth, iday, isec - REAL(wp) :: zsec + REAL(dp) :: zsec LOGICAL :: llexist TYPE(xios_duration) :: output_freq !!---------------------------------------------------------------------- @@ -2762,14 +2699,14 @@ FUNCTION iom_sdate( pjday, ld24, ldfull ) !! !! ** Purpose : send back the date corresponding to the given julian day !!---------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: pjday ! julian day + REAL(dp), INTENT(in ) :: pjday ! julian day LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss ! CHARACTER(LEN=20) :: iom_sdate CHARACTER(LEN=50) :: clfmt ! format used to write the date INTEGER :: iyear, imonth, iday, ihour, iminute, isec - REAL(wp) :: zsec + REAL(dp) :: zsec LOGICAL :: ll24, llfull !!---------------------------------------------------------------------- ! diff --git a/cfgs/GLOBAL_QCO/MY_SRC/istate.F90 b/cfgs/GLOBAL_QCO/MY_SRC/istate.F90 index d737af7..62ed822 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/istate.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/istate.F90 @@ -50,7 +50,7 @@ MODULE istate # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: istate.F90 14991 2021-06-14 19:52:31Z techene $ + !! $Id: istate.F90 15052 2021-06-24 14:39:14Z smasson $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -138,53 +138,38 @@ SUBROUTINE istate_init( Kbb, Kmm, Kaa ) END DO CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) ! make sure that periodicities are properly applied - CALL lbc_lnk( 'istate', ts(:,:,:,jp_tem,Kbb), 'T', 1._wp, ts(:,:,:,jp_sal,Kbb), 'T', 1._wp, & - & uu(:,:,:, Kbb), 'U', -1._wp, vv(:,:,:, Kbb), 'V', -1._wp ) + CALL lbc_lnk( 'istate', ts(:,:,:,jp_tem,Kbb), 'T', 1._dp, ts(:,:,:,jp_sal,Kbb), 'T', 1._dp, & + & uu(:,:,:, Kbb), 'U', -1._dp, vv(:,:,:, Kbb), 'V', -1._dp ) ENDIF ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones uu (:,:,:,Kmm) = uu (:,:,:,Kbb) vv (:,:,:,Kmm) = vv (:,:,:,Kbb) + ENDIF #if defined key_agrif ENDIF #endif ! -#if defined key_RK3 - IF( .NOT. ln_rstart ) THEN -#endif - ! Initialize "before" barotropic velocities. "now" values are always set but - ! "before" values may have been read from a restart to ensure restartability. - ! In the non-restart or non-RK3 cases they need to be initialised here: - uu_b(:,:,Kbb) = 0._wp ; vv_b(:,:,Kbb) = 0._wp - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk) - vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk) - END_3D - uu_b(:,:,Kbb) = uu_b(:,:,Kbb) * r1_hu(:,:,Kbb) - vv_b(:,:,Kbb) = vv_b(:,:,Kbb) * r1_hv(:,:,Kbb) - ! -#if defined key_RK3 - ENDIF -#endif - ! - ! Initialize "now" barotropic velocities: - ! Do it whatever the free surface method, these arrays being used eventually + ! Initialize "now" and "before" barotropic velocities: + ! Do it whatever the free surface method, these arrays being eventually used ! -#if defined key_RK3 - IF( .NOT. ln_rstart ) THEN - uu_b(:,:,Kmm) = uu_b(:,:,Kbb) ! Kmm value set to Kbb for initialisation in Agrif_Regrid in namo_gcm - vv_b(:,:,Kmm) = vv_b(:,:,Kbb) - ENDIF -#else -!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp + uu_b(:,:,Kbb) = 0._wp ; vv_b(:,:,Kbb) = 0._wp + ! +!!gm the use of umsak & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + ! + uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk) + vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk) END_3D + ! uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) -#endif + ! + uu_b(:,:,Kbb) = uu_b(:,:,Kbb) * r1_hu(:,:,Kbb) + vv_b(:,:,Kbb) = vv_b(:,:,Kbb) * r1_hv(:,:,Kbb) ! END SUBROUTINE istate_init diff --git a/cfgs/GLOBAL_QCO/MY_SRC/ldftra.F90 b/cfgs/GLOBAL_QCO/MY_SRC/ldftra.F90 index 955b187..2ba9c5d 100644 --- a/cfgs/GLOBAL_QCO/MY_SRC/ldftra.F90 +++ b/cfgs/GLOBAL_QCO/MY_SRC/ldftra.F90 @@ -67,8 +67,6 @@ MODULE ldftra ! != Use/diagnose eiv =! LOGICAL , PUBLIC :: ln_ldfeiv !: eddy induced velocity flag LOGICAL , PUBLIC :: ln_ldfeiv_dia !: diagnose & output eiv streamfunction and velocity (IOM) - LOGICAL , PUBLIC :: l_ldfeiv_dia !: RK3: modified w.r.t. kstg diagnose & output eiv streamfunction and velocity flag - ! != Coefficients =! INTEGER , PUBLIC :: nn_aei_ijk_t !: choice of time/space variation of the eiv coeff. REAL(wp), PUBLIC :: rn_Ue !: lateral diffusive velocity [m/s] @@ -100,7 +98,7 @@ MODULE ldftra # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: ldftra.F90 15512 2021-11-15 17:22:03Z techene $ + !! $Id: ldftra.F90 15475 2021-11-05 14:14:45Z cdllod $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -392,7 +390,7 @@ SUBROUTINE ldf_tra( kt, Kbb, Kmm ) !! with a reduction to 0 in vicinity of the Equator !! nn_aht_ijk_t = 21 ahtu, ahtv = F(i,j, t) = F(growth rate of baroclinic instability) !! - !! = 31 ahtu, ahtv = F(i,j,k,t) = F(local velocity) ( |u|e /12 laplacian operator + !! = 31 ahtu, ahtv = F(i,j,k,t) = F(local velocity) ( |u|e / 2 laplacian operator !! or |u|e^3/12 bilaplacian operator ) !! !! * time varying EIV coefficients: call to ldf_eiv routine @@ -443,10 +441,10 @@ SUBROUTINE ldf_tra( kt, Kbb, Kmm ) END DO ! CASE( 31 ) !== time varying 3D field ==! = F( local velocity ) - IF( ln_traldf_lap ) THEN ! laplacian operator |u| e /12 + IF( ln_traldf_lap ) THEN ! laplacian operator |u| e / 2 DO jk = 1, jpkm1 - ahtu(:,:,jk) = ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_12 ! n.b. uu,vv are masked - ahtv(:,:,jk) = ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_12 + ahtu(:,:,jk) = ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_2 ! n.b. uu,vv are masked + ahtv(:,:,jk) = ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_2 END DO ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator sqrt( |u| e^3 /12 ) = sqrt( |u| e /12 ) * e DO jk = 1, jpkm1 @@ -497,9 +495,8 @@ SUBROUTINE ldf_eiv_init INTEGER :: ierr, inum, ios, inn ! local integer REAL(wp) :: zah_max, zUfac ! - scalar !! - NAMELIST/namtra_eiv/ ln_ldfeiv , ln_ldfeiv_dia, & ! eddy induced velocity (eiv) - & nn_aei_ijk_t, rn_Ue, rn_Le, & ! eiv coefficient - & nn_ldfeiv_shape + NAMELIST/namtra_eiv/ ln_ldfeiv , ln_ldfeiv_dia, nn_ldfeiv_shape, & ! eddy induced velocity (eiv) + & nn_aei_ijk_t, rn_Ue, rn_Le ! eiv coefficient !!---------------------------------------------------------------------- ! IF(lwp) THEN ! control print @@ -802,7 +799,7 @@ SUBROUTINE ldf_eiv_trp( kt, kit000, pu, pv, pw, cdtype, Kmm, Krhs ) CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] - REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] !! INTEGER :: ji, jj, jk ! dummy loop indices @@ -840,11 +837,7 @@ SUBROUTINE ldf_eiv_trp( kt, kit000, pu, pv, pw, cdtype, Kmm, Krhs ) END_3D ! ! ! diagnose the eddy induced velocity and associated heat transport -#if defined key_RK3 - IF( l_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) -#else IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) -#endif ! END SUBROUTINE ldf_eiv_trp @@ -943,7 +936,7 @@ SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw, Kmm ) CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction ! - IF( iom_use( 'sophteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) + IF( iom_use( 'sophteiv' ) ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5_wp * zw3d ) ! zztmp = 0.5_wp * 0.5 IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN @@ -967,7 +960,7 @@ SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw, Kmm ) CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction ! - IF( iom_use( 'sopsteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) + IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5_wp * zw3d ) ! ! END SUBROUTINE ldf_eiv_dia diff --git a/cfgs/GLOBAL_QCO/cpp_GLOBAL_QCO.fcm b/cfgs/GLOBAL_QCO/cpp_GLOBAL_QCO.fcm index 60483e3..6b13ac3 100755 --- a/cfgs/GLOBAL_QCO/cpp_GLOBAL_QCO.fcm +++ b/cfgs/GLOBAL_QCO/cpp_GLOBAL_QCO.fcm @@ -1 +1 @@ - bld::tool::fppkeys key_si3 key_xios key_qco key_isf + bld::tool::fppkeys key_si3 key_xios key_qco diff --git a/cfgs/SHARED/field_def_nemo-oce.xml b/cfgs/SHARED/field_def_nemo-oce.xml index 63c7a8c..7a06eaa 100644 --- a/cfgs/SHARED/field_def_nemo-oce.xml +++ b/cfgs/SHARED/field_def_nemo-oce.xml @@ -185,6 +185,10 @@ that are available in the tidal-forcing implementation (see + + + + diff --git a/cfgs/SHARED/namelist_ref b/cfgs/SHARED/namelist_ref index 4ce6944..690d66a 100644 --- a/cfgs/SHARED/namelist_ref +++ b/cfgs/SHARED/namelist_ref @@ -133,7 +133,6 @@ !----------------------------------------------------------------------- &namwad ! Wetting and Drying (WaD) (default: OFF) !----------------------------------------------------------------------- - ln_wd_il = .false., ! T/F activation of iterative limiter ln_wd_dl = .false., ! T/F activation of directional limiter ln_wd_dl_bc = .false., ! T/F Directional limiteer Baroclinic option ln_wd_dl_rmp = .false., ! T/F Turn on directional limiter ramp @@ -141,7 +140,6 @@ rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells rn_wdld = 2.5 ! Land elevation below which WaD is allowed - nn_wdit = 20 ! Max iterations for WaD limiter rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) / diff --git a/data/INPUT_eORCA025_Anemone/bfr_coef.nc b/data/INPUT_eORCA025_Anemone/bfr_coef.nc new file mode 120000 index 0000000..ea578d0 --- /dev/null +++ b/data/INPUT_eORCA025_Anemone/bfr_coef.nc @@ -0,0 +1 @@ +/dssgfs01/working/atb299/NEMO_cfgs/eORCA025_v4.2/eORCA025_v4.2_bfr2d_v0.2.nc \ No newline at end of file diff --git a/data/INPUT_eORCA025_Anemone/domcfg.nc b/data/INPUT_eORCA025_Anemone/domcfg.nc new file mode 120000 index 0000000..b85573f --- /dev/null +++ b/data/INPUT_eORCA025_Anemone/domcfg.nc @@ -0,0 +1 @@ +/dssgfs01/working/atb299/NEMO_cfgs/eORCA025_RK3/BASE/domcfg.nc \ No newline at end of file diff --git a/data/INPUT_eORCA025_Anemone/domcfg.nc_newDS b/data/INPUT_eORCA025_Anemone/domcfg.nc_newDS new file mode 120000 index 0000000..8729d6c --- /dev/null +++ b/data/INPUT_eORCA025_Anemone/domcfg.nc_newDS @@ -0,0 +1 @@ +/dssgfs01/working/atb299/NEMO_cfgs/domain_cfg_eORCA025_GEBCO2021_S21TT_edits-20220404_closea-mask-v3_nohaloes_maskclosea.nc \ No newline at end of file diff --git a/data/INPUT_eORCA025_Anemone/geothermal_heating_orca025ext_extrap40_v4.2.nc b/data/INPUT_eORCA025_Anemone/geothermal_heating_orca025ext_extrap40_v4.2.nc new file mode 120000 index 0000000..c598666 --- /dev/null +++ b/data/INPUT_eORCA025_Anemone/geothermal_heating_orca025ext_extrap40_v4.2.nc @@ -0,0 +1 @@ +/dssgfs01/working/atb299/NEMO_cfgs/eORCA025_v4.2/geothermal_heating_orca025ext_extrap40_v4.2.nc \ No newline at end of file diff --git a/scripts/setup b/scripts/setup index b4718ec..b666710 100755 --- a/scripts/setup +++ b/scripts/setup @@ -4,11 +4,11 @@ WD=$PWD SYSTEM=Anemone -#BRANCH=branch_4.2 -#COMMIT=405258c9896e0b1a3c430ea495fcda0fe55e2170 +BRANCH=branch_4.2 +COMMIT=b1b3d9e142670c8358f240a8eeb13979600d8039 -BRANCH=main -COMMIT=9a86d855a3ad9210b18ad8cf160dd5ecec4da466 +#BRANCH=main +#COMMIT=9a86d855a3ad9210b18ad8cf160dd5ecec4da466 NEMODIR=${WD}/nemo STOP=0 @@ -91,9 +91,9 @@ cp -r "${WD}"/scripts/TIDY "$NEMODIR"/cfgs/GLOBAL_QCO/EXP_MASTER/. # TOOLS ########################################### # Compile tools -echo "Compiling tools" -cd "$NEMODIR"/tools || exit -../scripts/compile_tools || exit +#echo "Compiling tools" +#cd "$NEMODIR"/tools || exit +#../scripts/compile_tools || exit ########################################### # CONFIGURATIONS